aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMatthew Somerville <matthew@mysociety.org>2017-07-03 12:53:54 +0100
committerMatthew Somerville <matthew@mysociety.org>2017-07-04 10:32:39 +0100
commitf52a086bce1dee6110aed24f85670d35b92f5ff3 (patch)
tree77307b158530da9e3684b5d5b23f2f52fefede6a
parent19c7a8e1f7bd2774affd890698e40902a8c19a34 (diff)
Update carton/cpanm to handle 5.24 @INC change.
-rwxr-xr-xbin/cpanm48
-rwxr-xr-xvendor/bin/carton17305
2 files changed, 6653 insertions, 10700 deletions
diff --git a/bin/cpanm b/bin/cpanm
index 9676fae7e..7f81ee80f 100755
--- a/bin/cpanm
+++ b/bin/cpanm
@@ -21,7 +21,7 @@ BEGIN {
my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
- package App::cpanminus;our$VERSION="1.7039";1;
+ package App::cpanminus;our$VERSION="1.7043";1;
APP_CPANMINUS
$fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY';
@@ -29,7 +29,7 @@ $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__.
APP_CPANMINUS_DEPENDENCY
$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 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 version::vpp}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,exclude_vendor=>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=>!$class->maybe_ci,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}sub maybe_ci {my$class=shift;grep$ENV{$_},qw(TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING)}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},'exclude-vendor!'=>\$self->{exclude_vendor},'mirror=s@'=>$self->{mirrors},'mirror-only!'=>\$self->{mirror_only},'mirror-index=s'=>sub {$self->{mirror_index}=$self->maybe_abs($_[1])},'M|from=s'=>sub {$self->{mirrors}=[$_[1]];$self->{mirror_only}=1},'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}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)=@_;if ($version =~ /==/){return}elsif ($self->{dev_release}){return +{not=>{term=>{status=>'backpan' }}}}else {return ({not=>{term=>{status=>'backpan' }}},{term=>{maturity=>'released' }},)}}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;if ($self->{dev_release}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 ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version)}else {return$self->search_cpanmetadb_package($module,$version)}}sub search_cpanmetadb_package {my($self,$module,$version)=@_;require CPAN::Meta::YAML;(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_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) 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 sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}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})){return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub upgrade_toolchain {my($self,$config_deps)=@_;my%deps=map {$_->module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}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}}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 =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}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 =~ 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;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){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->requires_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.38' },'configure',)}$self->upgrade_toolchain(\@config_deps);my$target=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};{local$self->{notest}=1;$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");if ($dist->{cpanmeta}&& $dist->{source}eq 'cpan'){$dist->{provides}=$dist->{cpanmeta}{provides}|| $self->extract_packages($dist->{cpanmeta},".")}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,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });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)}if ($self->{cpanfile_requirements}&&!$dist->{cpanfile}){for my$dep (@deps){$dep->merge_with($self->{cpanfile_requirements})}}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);$self->{cpanfile_requirements}=$prereqs->merged_requirements($dist->{want_phases},['requires']);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);my$prereqs=$self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}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;
+ 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 version::vpp}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,exclude_vendor=>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,with_configure=>0,showdeps=>0,scandeps=>0,scandeps_tree=>[],format=>'tree',save_dists=>undef,skip_configure=>0,verify=>0,report_perl_version=>!$class->maybe_ci,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}sub maybe_ci {my$class=shift;grep$ENV{$_},qw(TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING)}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},'exclude-vendor!'=>\$self->{exclude_vendor},'mirror=s@'=>$self->{mirrors},'mirror-only!'=>\$self->{mirror_only},'mirror-index=s'=>sub {$self->{mirror_index}=$self->maybe_abs($_[1])},'M|from=s'=>sub {$self->{mirrors}=[$_[1]];$self->{mirror_only}=1},'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-configure'=>\$self->{with_configure},'without-configure'=>sub {$self->{with_configure}=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}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)=@_;if ($version =~ /==/){return}elsif ($self->{dev_release}){return +{not=>{term=>{status=>'backpan' }}}}else {return ({not=>{term=>{status=>'backpan' }}},{term=>{maturity=>'released' }},)}}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;if ($self->{dev_release}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 ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version)}else {return$self->search_cpanmetadb_package($module,$version)}}sub search_cpanmetadb_package {my($self,$module,$version)=@_;require CPAN::Meta::YAML;(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_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) 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 sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}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})){return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub upgrade_toolchain {my($self,$config_deps)=@_;my%deps=map {$_->module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}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}}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"}local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};$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};local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};$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;local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};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}local$ENV{PERL_USE_UNSAFE_INC}=1 unless exists$ENV{PERL_USE_UNSAFE_INC};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 =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}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 =~ 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;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){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->requires_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.38' },'configure',)}$self->merge_with_cpanfile($dist,\@config_deps);$self->upgrade_toolchain(\@config_deps);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");if ($dist->{cpanmeta}&& $dist->{source}eq 'cpan'){$dist->{provides}=$dist->{cpanmeta}{provides}|| $self->extract_packages($dist->{cpanmeta},".")}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;push @{$dist->{want_phases}},'configure' if$self->{with_configure}&& $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,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });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)}$self->merge_with_cpanfile($dist,\@deps);return@deps}sub merge_with_cpanfile {my($self,$dist,$deps)=@_;if ($self->{cpanfile_requirements}&&!$dist->{cpanfile}){for my$dep (@$deps){$dep->merge_with($self->{cpanfile_requirements})}}}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);$self->{cpanfile_requirements}=$prereqs->merged_requirements($dist->{want_phases},['requires']);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$match;if ($dist->{module}){$match=sub {my$meta=Module::Metadata->new_from_file($_[0]);$meta && ($meta->name eq $dist->{module})}}else {$match=sub {1}}my@files;File::Find::find({wanted=>sub {push@files,File::Spec->rel2abs($_)if /\.pm$/i && $match->($_)},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);my$prereqs=$self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}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);my$source_mtime=(stat$file)[9];return 1 if -e $path && (stat$path)[9]>= $source_mtime;File::Copy::copy($file,$path);utime$source_mtime,$source_mtime,$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.
@@ -104,7 +104,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
! To turn off this warning, you have to do one of the following:
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
- ! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc.
+ ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
! - Install local::lib by running the following commands
!
! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
@@ -465,15 +465,17 @@ no strict 'refs';
if ($] < 5.008) {
*{"${class}::INC"} = sub {
- if (my $fat = $_[0]{$_[1]}) {
- return sub {
- return 0 unless length $fat;
- $fat =~ s/^([^\n]*\n?)//;
- $_ = $1;
- return 1;
- };
- }
- return;
+ if (my $fat = $_[0]{$_[1]}) {
+ my $pos = 0;
+ my $last = length $fat;
+ return (sub {
+ return 0 if $pos == $last;
+ my $next = (1 + index $fat, "\n", $pos) || $last;
+ $_ .= substr $fat, $pos, $next - $pos;
+ $pos = $next;
+ return 1;
+ });
+ }
};
}
@@ -816,6 +818,11 @@ Defaults to false for both.
B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
C<cpanfile> when used with C<--installdeps>. Defaults to false.
+=item --with-configure
+
+B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile>
+when used with C<--installdeps>. Defaults to false.
+
=item --with-feature, --without-feature, --with-all-features
B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
@@ -1036,6 +1043,23 @@ Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
=back
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item PERL_CPANM_HOME
+
+The directory cpanm should use to store downloads and build and test
+modules. Defaults to the C<.cpanm> directory in your user's home
+directory.
+
+=item PERL_CPANM_OPT
+
+If set, adds a set of default options to every cpanm command. These
+options come first, and so are overridden by command-line options.
+
+=back
+
=head1 SEE ALSO
L<App::cpanminus>
diff --git a/vendor/bin/carton b/vendor/bin/carton
index b311208a4..0a714c6d7 100755
--- a/vendor/bin/carton
+++ b/vendor/bin/carton
@@ -7,7 +7,7 @@ my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
package App::cpanminus;
- our $VERSION = "1.7039";
+ our $VERSION = "1.7043";
=encoding utf8
@@ -117,7 +117,7 @@ $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'A
It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
The site is updated at least every hour to reflect the latest changes
from fast syncing mirrors. The script then also falls back to query the
- module at L<http://metacpan.org/> using its seach API.
+ module at L<http://metacpan.org/> using its search API.
Upon calling these API hosts, cpanm (1.6004 or later) will send the
local perl versions to the server in User-Agent string by default. You
@@ -272,7 +272,7 @@ $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'A
=item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
- =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
+ =item L<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools
=back
@@ -316,7 +316,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
package App::cpanminus;
- our $VERSION = "1.7039";
+ our $VERSION = "1.7043";
=encoding utf8
@@ -426,7 +426,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
The site is updated at least every hour to reflect the latest changes
from fast syncing mirrors. The script then also falls back to query the
- module at L<http://metacpan.org/> using its seach API.
+ module at L<http://metacpan.org/> using its search API.
Upon calling these API hosts, cpanm (1.6004 or later) will send the
local perl versions to the server in User-Agent string by default. You
@@ -581,7 +581,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
=item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
- =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
+ =item L<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools
=back
@@ -777,6 +777,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
installed_dists => 0,
install_types => ['requires'],
with_develop => 0,
+ with_configure => 0,
showdeps => 0,
scandeps => 0,
scandeps_tree => [],
@@ -902,6 +903,8 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
'test-timeout=i' => \$self->{test_timeout},
'with-develop' => \$self->{with_develop},
'without-develop' => sub { $self->{with_develop} = 0 },
+ 'with-configure' => \$self->{with_configure},
+ 'without-configure' => sub { $self->{with_configure} = 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 },
@@ -1652,7 +1655,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
! To turn off this warning, you have to do one of the following:
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
- ! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc.
+ ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
! - Install local::lib by running the following commands
!
! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
@@ -1947,6 +1950,9 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$ENV{PERL_MB_OPT} .= " --pureperl-only";
}
+ local $ENV{PERL_USE_UNSAFE_INC} = 1
+ unless exists $ENV{PERL_USE_UNSAFE_INC};
+
$cmd = $self->append_args($cmd, 'configure') if $depth == 0;
local $self->{verbose} = $self->{verbose} || $self->{interactive};
@@ -1958,6 +1964,9 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
+ local $ENV{PERL_USE_UNSAFE_INC} = 1
+ unless exists $ENV{PERL_USE_UNSAFE_INC};
+
$cmd = $self->append_args($cmd, 'build') if $depth == 0;
return 1 if $self->run_timeout($cmd, $self->{build_timeout});
@@ -1982,6 +1991,9 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$cmd = $self->append_args($cmd, 'test') if $depth == 0;
+ local $ENV{PERL_USE_UNSAFE_INC} = 1
+ unless exists $ENV{PERL_USE_UNSAFE_INC};
+
return 1 if $self->run_timeout($cmd, $self->{test_timeout});
if ($self->{force}) {
$self->diag_fail("Testing $distname failed but installing it anyway.");
@@ -2006,6 +2018,9 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
return 1;
}
+ local $ENV{PERL_USE_UNSAFE_INC} = 1
+ unless exists $ENV{PERL_USE_UNSAFE_INC};
+
if ($self->{sudo}) {
unshift @$cmd, "sudo";
}
@@ -2848,6 +2863,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$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},
@@ -2860,11 +2876,12 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
);
}
+ $self->merge_with_cpanfile($dist, \@config_deps);
+
$self->upgrade_toolchain(\@config_deps);
my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
{
- local $self->{notest} = 1;
$self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
or return;
}
@@ -2884,6 +2901,7 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
? [qw( build runtime )] : [qw( build test runtime )];
push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;
+ push @{$dist->{want_phases}}, 'configure' if $self->{with_configure} && $depth == 0;
my @deps = $self->find_prereqs($dist);
my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
@@ -3277,13 +3295,19 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
push @deps, $self->bundle_deps($dist);
}
+ $self->merge_with_cpanfile($dist, \@deps);
+
+ return @deps;
+ }
+
+ sub merge_with_cpanfile {
+ my($self, $dist, $deps) = @_;
+
if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) {
- for my $dep (@deps) {
+ for my $dep (@$deps) {
$dep->merge_with($self->{cpanfile_requirements});
}
}
-
- return @deps;
}
sub extract_meta_prereqs {
@@ -3344,9 +3368,21 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
sub bundle_deps {
my($self, $dist) = @_;
+ my $match;
+ if ($dist->{module}) {
+ $match = sub {
+ my $meta = Module::Metadata->new_from_file($_[0]);
+ $meta && ($meta->name eq $dist->{module});
+ };
+ } else {
+ $match = sub { 1 };
+ }
+
my @files;
File::Find::find({
- wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
+ wanted => sub {
+ push @files, File::Spec->rel2abs($_) if /\.pm$/i && $match->($_);
+ },
no_chdir => 1,
}, '.');
@@ -3565,7 +3601,15 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
sub file_mirror {
my($self, $uri, $path) = @_;
my $file = $self->uri_to_file($uri);
+
+ my $source_mtime = (stat $file)[9];
+
+ # Don't mirror a file that's already there (like the index)
+ return 1 if -e $path && (stat $path)[9] >= $source_mtime;
+
File::Copy::copy($file, $path);
+
+ utime $source_mtime, $source_mtime, $path;
}
sub has_working_lwp {
@@ -24997,15 +25041,17 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
if ($] < 5.008) {
*{"${class}::INC"} = sub {
- if (my $fat = $_[0]{$_[1]}) {
- return sub {
- return 0 unless length $fat;
- $fat =~ s/^([^\n]*\n?)//;
- $_ = $1;
- return 1;
- };
- }
- return;
+ if (my $fat = $_[0]{$_[1]}) {
+ my $pos = 0;
+ my $last = length $fat;
+ return (sub {
+ return 0 if $pos == $last;
+ my $next = (1 + index $fat, "\n", $pos) || $last;
+ $_ .= substr $fat, $pos, $next - $pos;
+ $pos = $next;
+ return 1;
+ });
+ }
};
}
@@ -25348,6 +25394,11 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
C<cpanfile> when used with C<--installdeps>. Defaults to false.
+ =item --with-configure
+
+ B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile>
+ when used with C<--installdeps>. Defaults to false.
+
=item --with-feature, --without-feature, --with-all-features
B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
@@ -25568,6 +25619,23 @@ $fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
=back
+ =head1 ENVIRONMENT VARIABLES
+
+ =over 4
+
+ =item PERL_CPANM_HOME
+
+ The directory cpanm should use to store downloads and build and test
+ modules. Defaults to the C<.cpanm> directory in your user's home
+ directory.
+
+ =item PERL_CPANM_OPT
+
+ If set, adds a set of default options to every cpanm command. These
+ options come first, and so are overridden by command-line options.
+
+ =back
+
=head1 SEE ALSO
L<App::cpanminus>
@@ -34046,7 +34114,7 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
package Carton;
use strict;
use 5.008_005;
- use version; our $VERSION = version->declare("v1.0.22");
+ use version; our $VERSION = version->declare("v1.0.28");
1;
__END__
@@ -34183,7 +34251,7 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
=over 4
- =item L<https://github.com/miyagawa/carton>
+ =item L<https://github.com/perl-carton/carton>
Code repository, Wiki and Issue Tracker
@@ -34702,6 +34770,13 @@ $fatpacked{"Carton/CLI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CART
$env->snapshot->save;
}
+ sub cmd_run {
+ my($self, @args) = @_;
+
+ local $UseSystem = 1;
+ $self->cmd_exec(@args);
+ }
+
sub cmd_exec {
my($self, @args) = @_;
@@ -35065,7 +35140,7 @@ $fatpacked{"Carton/Index.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CA
EOF
for my $p ($self->packages) {
- print $fh $self->_format_line($p->name, $p->version || 'undef', $p->pathname);
+ print $fh $self->_format_line($p->name, $p->version_format, $p->pathname);
}
}
@@ -35134,6 +35209,11 @@ $fatpacked{"Carton/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
return { name => $args[0], version => $args[1], pathname => $args[2] };
}
+ sub version_format {
+ my $self = shift;
+ defined $self->version ? $self->version : 'undef';
+ }
+
1;
@@ -35192,7 +35272,7 @@ $fatpacked{"Carton/Packer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'C
# HACK: File::Spec bundled into arch in < 5.16, but is loadable as pure-perl
use Config;
- $fatpacked =~ s/\$fatpacked{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g;
+ $fatpacked =~ s/\$fatpacked\{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g;
$fatpacked;
}
@@ -35451,7 +35531,9 @@ $fatpacked{"Carton/Snapshot/Emitter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$data .= " provides:\n";
for my $package (sort keys %{$dist->provides}) {
- $data .= " $package @{[$dist->provides->{$package}{version} || 'undef' ]}\n";
+ my $version = $dist->provides->{$package}{version};
+ $version = 'undef' unless defined $version;
+ $data .= " $package $version\n";
}
$data .= " requirements:\n";
@@ -35540,7 +35622,6 @@ $fatpacked{"Carton/Snapshot/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
re => qr/^\s{6}([0-9A-Za-z_:]+) ([v0-9\._,=\!<>\s]+|undef)/,
code => sub {
my($stash, $snapshot, $module, $version) = @_;
-
if ($stash->{property} eq 'provides') {
$stash->{dist}->provides->{$module} = { version => $version };
} else {
@@ -35587,7 +35668,7 @@ $fatpacked{"Carton/Snapshot/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
}
}
- Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file.");
+ Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file: $line");
}
}
}
@@ -35710,7 +35791,7 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
package Class::Tiny;
# ABSTRACT: Minimalist class construction
- our $VERSION = '1.001';
+ our $VERSION = '1.006';
use Carp ();
@@ -35740,28 +35821,63 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
or Carp::croak "Invalid accessor name '$_'"
} keys %defaults;
$CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
- _gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
+ $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}
sub _gen_accessor {
- my ( $pkg, $name ) = @_;
+ my ( $class, $pkg, $name ) = @_;
my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};
- my $sub = "sub $name { if (\@_ == 1) {";
- if ( defined $outer_default && ref $outer_default eq 'CODE' ) {
- $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default->(\$_[0]) }";
- }
- elsif ( defined $outer_default ) {
- $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default }";
- }
- $sub .= "return \$_[0]{$name} } else { return \$_[0]{$name}=\$_[1] } }";
+ my $sub =
+ $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );
# default = outer_default avoids "won't stay shared" bug
eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}
+ # NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
+ # could break if the internals of Class::Tiny need to change for any
+ # reason. That said, I currently see no reason why this would be likely to
+ # change.
+ #
+ # The generated sub body should assume that a '$default' variable will be
+ # in scope (i.e. when the sub is evaluated) with any default value/coderef
+ sub __gen_sub_body {
+ my ( $self, $name, $has_default, $default_type ) = @_;
+
+ if ( $has_default && $default_type eq 'CODE' ) {
+ return << "HERE";
+ sub $name {
+ return (
+ ( \@_ == 1 && exists \$_[0]{$name} )
+ ? ( \$_[0]{$name} )
+ : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
+ );
+ }
+ HERE
+ }
+ elsif ($has_default) {
+ return << "HERE";
+ sub $name {
+ return (
+ ( \@_ == 1 && exists \$_[0]{$name} )
+ ? ( \$_[0]{$name} )
+ : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
+ );
+ }
+ HERE
+ }
+ else {
+ return << "HERE";
+ sub $name {
+ return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] );
+ }
+ HERE
+ }
+ }
+
sub get_all_attributes_for {
my ( $class, $pkg ) = @_;
my %attr =
@@ -35784,7 +35900,7 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
package Class::Tiny::Object;
# ABSTRACT: Base class for classes built with Class::Tiny
- our $VERSION = '1.001';
+ our $VERSION = '1.006';
my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
@@ -35880,7 +35996,7 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
=head1 VERSION
- version 1.001
+ version 1.006
=head1 SYNOPSIS
@@ -36255,7 +36371,7 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
=head1 CONTRIBUTORS
- =for stopwords Dagfinn Ilmari Mannsåker Gelu Lupas Karen Etheridge Matt S Trout Olivier Mengué Toby Inkster
+ =for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Olivier Mengué Toby Inkster
=over 4
@@ -36265,15 +36381,15 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
=item *
- Gelu Lupas <gelu@devnull.ro>
+ David Golden <xdg@xdg.me>
=item *
- Karen Etheridge <ether@cpan.org>
+ Gelu Lupas <gelu@devnull.ro>
=item *
- Matt S Trout <mstrout@cpan.org>
+ Karen Etheridge <ether@cpan.org>
=item *
@@ -36296,119 +36412,6 @@ $fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLAS
=cut
CLASS_TINY
-$fatpacked{"Devel/GlobalDestruction.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_GLOBALDESTRUCTION';
- package Devel::GlobalDestruction;
-
- use strict;
- use warnings;
-
- our $VERSION = '0.13';
-
- use Sub::Exporter::Progressive -setup => {
- exports => [ qw(in_global_destruction) ],
- groups => { default => [ -all ] },
- };
-
- # we run 5.14+ - everything is in core
- #
- if (defined ${^GLOBAL_PHASE}) {
- eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1'
- or die $@;
- }
- # try to load the xs version if it was compiled
- #
- elsif (eval {
- require Devel::GlobalDestruction::XS;
- no warnings 'once';
- *in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction;
- 1;
- }) {
- # the eval already installed everything, nothing to do
- }
- else {
- # internally, PL_main_cv is set to Nullcv immediately before entering
- # global destruction and we can use B to detect that. B::main_cv will
- # only ever be a B::CV or a B::SPECIAL that is a reference to 0
- require B;
- eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1'
- or die $@;
- }
-
- 1; # keep require happy
-
-
- __END__
-
- =head1 NAME
-
- Devel::GlobalDestruction - Provides function returning the equivalent of
- C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls.
-
- =head1 SYNOPSIS
-
- package Foo;
- use Devel::GlobalDestruction;
-
- use namespace::clean; # to avoid having an "in_global_destruction" method
-
- sub DESTROY {
- return if in_global_destruction;
-
- do_something_a_little_tricky();
- }
-
- =head1 DESCRIPTION
-
- Perl's global destruction is a little tricky to deal with WRT finalizers
- because it's not ordered and objects can sometimes disappear.
-
- Writing defensive destructors is hard and annoying, and usually if global
- destruction is happening you only need the destructors that free up non
- process local resources to actually execute.
-
- For these constructors you can avoid the mess by simply bailing out if global
- destruction is in effect.
-
- =head1 EXPORTS
-
- This module uses L<Sub::Exporter::Progressive> so the exports may be renamed,
- aliased, etc. if L<Sub::Exporter> is present.
-
- =over 4
-
- =item in_global_destruction
-
- Returns true if the interpreter is in global destruction. In perl 5.14+, this
- returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using
- the value of C<PL_main_cv> or C<PL_dirty>.
-
- =back
-
- =head1 AUTHORS
-
- Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
-
- Florian Ragwitz E<lt>rafl@debian.orgE<gt>
-
- Jesse Luehrs E<lt>doy@tozt.netE<gt>
-
- Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
-
- Arthur Axel 'fREW' Schmidt E<lt>frioux@gmail.comE<gt>
-
- Elizabeth Mattijsen E<lt>liz@dijkmat.nlE<gt>
-
- Greham Knop E<lt>haarg@haarg.orgE<gt>
-
- =head1 COPYRIGHT
-
- Copyright (c) 2008 Yuval Kogman. All rights reserved
- This program is free software; you can redistribute
- it and/or modify it under the same terms as Perl itself.
-
- =cut
-DEVEL_GLOBALDESTRUCTION
-
$fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND';
package ExtUtils::Command;
@@ -36419,7 +36422,7 @@ $fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
dos2unix);
- $VERSION = '7.06';
+ $VERSION = '7.30';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
@@ -36432,7 +36435,10 @@ $fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $vms_efs;
my $vms_case;
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+ if (eval { local $SIG{__DIE__};
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require VMS::Feature; }) {
$vms_unix_rpt = VMS::Feature::current("filename_unix_report");
$vms_efs = VMS::Feature::current("efs_charset");
$vms_case = VMS::Feature::current("efs_case_preserve");
@@ -36759,6 +36765,7 @@ $fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
open TEMP, ">$temp" or
do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
+ binmode ORIG; binmode TEMP;
while (my $line = <ORIG>) {
$line =~ s/\015\012/\012/g;
print TEMP $line;
@@ -36802,15 +36809,20 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
my $Is_VMS = $^O eq 'VMS';
- eval { require Time::HiRes; die unless Time::HiRes->can("stat"); };
- *mtime = $@ ?
- sub { [ stat($_[0])]->[9] } :
- sub { [Time::HiRes::stat($_[0])]->[9] } ;
+ sub mtime {
+ no warnings 'redefine';
+ local $@;
+ *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat)
+ ? sub { (Time::HiRes::stat($_[0]))[9] }
+ : sub { ( stat($_[0]))[9] }
+ ;
+ goto &mtime;
+ }
=head1 NAME
@@ -37006,8 +37018,9 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
: @ARGV;
my $pod;
- $pod = sprintf <<'POD', scalar(localtime), $type, $name;
- =head2 %s: C<%s> L<%3$s|%3$s>
+ my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
+ $pod = sprintf <<'POD', scalar($time), $type, $name, $name;
+ =head2 %s: C<%s> L<%s|%s>
=over 4
@@ -37109,12 +37122,1845 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
1;
EXTUTILS_COMMAND_MM
+$fatpacked{"ExtUtils/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALL';
+ package ExtUtils::Install;
+ use strict;
+
+ use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
+
+ use AutoSplit;
+ use Carp ();
+ use Config qw(%Config);
+ use Cwd qw(cwd);
+ use Exporter;
+ use ExtUtils::Packlist;
+ use File::Basename qw(dirname);
+ use File::Compare qw(compare);
+ use File::Copy;
+ use File::Find qw(find);
+ use File::Path;
+ use File::Spec;
+
+
+ @ISA = ('Exporter');
+ @EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
+
+ =pod
+
+ =head1 NAME
+
+ ExtUtils::Install - install files from here to there
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::Install;
+
+ install({ 'blib/lib' => 'some/install/dir' } );
+
+ uninstall($packlist);
+
+ pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
+
+ =head1 VERSION
+
+ 2.06
+
+ =cut
+
+ $VERSION = '2.06'; # <-- do not forget to update the POD section just above this line!
+ $VERSION = eval $VERSION;
+
+ =pod
+
+ =head1 DESCRIPTION
+
+ Handles the installing and uninstalling of perl modules, scripts, man
+ pages, etc...
+
+ Both install() and uninstall() are specific to the way
+ ExtUtils::MakeMaker handles the installation and deinstallation of
+ perl modules. They are not designed as general purpose tools.
+
+ On some operating systems such as Win32 installation may not be possible
+ until after a reboot has occurred. This can have varying consequences:
+ removing an old DLL does not impact programs using the new one, but if
+ a new DLL cannot be installed properly until reboot then anything
+ depending on it must wait. The package variable
+
+ $ExtUtils::Install::MUST_REBOOT
+
+ is used to store this status.
+
+ If this variable is true then such an operation has occurred and
+ anything depending on this module cannot proceed until a reboot
+ has occurred.
+
+ If this value is defined but false then such an operation has
+ ocurred, but should not impact later operations.
+
+ =over
+
+ =begin _private
+
+ =item _chmod($$;$)
+
+ Wrapper to chmod() for debugging and error trapping.
+
+ =item _warnonce(@)
+
+ Warns about something only once.
+
+ =item _choke(@)
+
+ Dies with a special message.
+
+ =back
+
+ =end _private
+
+ =cut
+
+ my $Is_VMS = $^O eq 'VMS';
+ my $Is_MacPerl = $^O eq 'MacOS';
+ my $Is_Win32 = $^O eq 'MSWin32';
+ my $Is_cygwin = $^O eq 'cygwin';
+ my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
+
+
+ my $Inc_uninstall_warn_handler;
+
+ # install relative to here
+
+ my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
+ my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET};
+
+ my $Curdir = File::Spec->curdir;
+ my $Updir = File::Spec->updir;
+
+ sub _estr(@) {
+ return join "\n",'!' x 72,@_,'!' x 72,'';
+ }
+
+ {my %warned;
+ sub _warnonce(@) {
+ my $first=shift;
+ my $msg=_estr "WARNING: $first",@_;
+ warn $msg unless $warned{$msg}++;
+ }}
+
+ sub _choke(@) {
+ my $first=shift;
+ my $msg=_estr "ERROR: $first",@_;
+ Carp::croak($msg);
+ }
+
+
+ sub _chmod($$;$) {
+ my ( $mode, $item, $verbose )=@_;
+ $verbose ||= 0;
+ if (chmod $mode, $item) {
+ printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
+ } else {
+ my $err="$!";
+ _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
+ $mode, $item, $err
+ if -e $item;
+ }
+ }
+
+ =begin _private
+
+ =over
+
+ =item _move_file_at_boot( $file, $target, $moan )
+
+ OS-Specific, Win32/Cygwin
+
+ Schedules a file to be moved/renamed/deleted at next boot.
+ $file should be a filespec of an existing file
+ $target should be a ref to an array if the file is to be deleted
+ otherwise it should be a filespec for a rename. If the file is existing
+ it will be replaced.
+
+ Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred
+ and sets it to 1 to indicate that a move operation has been requested.
+
+ returns 1 on success, on failure if $moan is false errors are fatal.
+ If $moan is true then returns 0 on error and warns instead of dies.
+
+ =end _private
+
+ =cut
+
+ {
+ my $Has_Win32API_File;
+ sub _move_file_at_boot { #XXX OS-SPECIFIC
+ my ( $file, $target, $moan )= @_;
+ Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
+ unless $CanMoveAtBoot;
+
+ my $descr= ref $target
+ ? "'$file' for deletion"
+ : "'$file' for installation as '$target'";
+
+ # *note* CanMoveAtBoot is only incidentally the same condition as below
+ # this needs not hold true in the future.
+ $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
+ ? (eval {require Win32API::File; 1} || 0)
+ : 0 unless defined $Has_Win32API_File;
+ if ( ! $Has_Win32API_File ) {
+
+ my @msg=(
+ "Cannot schedule $descr at reboot.",
+ "Try installing Win32API::File to allow operations on locked files",
+ "to be scheduled during reboot. Or try to perform the operation by",
+ "hand yourself. (You may need to close other perl processes first)"
+ );
+ if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
+ return 0;
+ }
+ my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
+ $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
+ unless ref $target;
+
+ _chmod( 0666, $file );
+ _chmod( 0666, $target ) unless ref $target;
+
+ if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
+ $MUST_REBOOT ||= ref $target ? 0 : 1;
+ return 1;
+ } else {
+ my @msg=(
+ "MoveFileEx $descr at reboot failed: $^E",
+ "You may try to perform the operation by hand yourself. ",
+ "(You may need to close other perl processes first).",
+ );
+ if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
+ }
+ return 0;
+ }
+ }
+
+
+ =begin _private
+
+
+ =item _unlink_or_rename( $file, $tryhard, $installing )
+
+ OS-Specific, Win32/Cygwin
+
+ Tries to get a file out of the way by unlinking it or renaming it. On
+ some OS'es (Win32 based) DLL files can end up locked such that they can
+ be renamed but not deleted. Likewise sometimes a file can be locked such
+ that it cant even be renamed or changed except at reboot. To handle
+ these cases this routine finds a tempfile name that it can either rename
+ the file out of the way or use as a proxy for the install so that the
+ rename can happen later (at reboot).
+
+ $file : the file to remove.
+ $tryhard : should advanced tricks be used for deletion
+ $installing : we are not merely deleting but we want to overwrite
+
+ When $tryhard is not true if the unlink fails its fatal. When $tryhard
+ is true then the file is attempted to be renamed. The renamed file is
+ then scheduled for deletion. If the rename fails then $installing
+ governs what happens. If it is false the failure is fatal. If it is true
+ then an attempt is made to schedule installation at boot using a
+ temporary file to hold the new file. If this fails then a fatal error is
+ thrown, if it succeeds it returns the temporary file name (which will be
+ a derivative of the original in the same directory) so that the caller can
+ use it to install under. In all other cases of success returns $file.
+ On failure throws a fatal error.
+
+ =end _private
+
+ =cut
+
+
+
+ sub _unlink_or_rename { #XXX OS-SPECIFIC
+ my ( $file, $tryhard, $installing )= @_;
+
+ # this chmod was originally unconditional. However, its not needed on
+ # POSIXy systems since permission to unlink a file is specified by the
+ # directory rather than the file; and in fact it screwed up hard- and
+ # symlinked files. Keep it for other platforms in case its still
+ # needed there.
+ if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) {
+ _chmod( 0666, $file );
+ }
+ my $unlink_count = 0;
+ while (unlink $file) { $unlink_count++; }
+ return $file if $unlink_count > 0;
+ my $error="$!";
+
+ _choke("Cannot unlink '$file': $!")
+ unless $CanMoveAtBoot && $tryhard;
+
+ my $tmp= "AAA";
+ ++$tmp while -e "$file.$tmp";
+ $tmp= "$file.$tmp";
+
+ warn "WARNING: Unable to unlink '$file': $error\n",
+ "Going to try to rename it to '$tmp'.\n";
+
+ if ( rename $file, $tmp ) {
+ warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n";
+ # when $installing we can set $moan to true.
+ # IOW, if we cant delete the renamed file at reboot its
+ # not the end of the world. The other cases are more serious
+ # and need to be fatal.
+ _move_file_at_boot( $tmp, [], $installing );
+ return $file;
+ } elsif ( $installing ) {
+ _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
+ " installation as '$file' at reboot.\n");
+ _move_file_at_boot( $tmp, $file );
+ return $tmp;
+ } else {
+ _choke("Rename failed:$!", "Cannot proceed.");
+ }
+
+ }
+
+
+ =pod
+
+ =back
+
+ =head2 Functions
+
+ =begin _private
+
+ =over
+
+ =item _get_install_skip
+
+ Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
+
+ =cut
+
+
+
+ sub _get_install_skip {
+ my ( $skip, $verbose )= @_;
+ if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
+ print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
+ if $verbose>2;
+ return [];
+ }
+ if ( ! defined $skip ) {
+ print "Looking for install skip list\n"
+ if $verbose>2;
+ for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
+ next unless $file;
+ print "\tChecking for $file\n"
+ if $verbose>2;
+ if (-e $file) {
+ $skip= $file;
+ last;
+ }
+ }
+ }
+ if ($skip && !ref $skip) {
+ print "Reading skip patterns from '$skip'.\n"
+ if $verbose;
+ if (open my $fh,$skip ) {
+ my @patterns;
+ while (<$fh>) {
+ chomp;
+ next if /^\s*(?:#|$)/;
+ print "\tSkip pattern: $_\n" if $verbose>3;
+ push @patterns, $_;
+ }
+ $skip= \@patterns;
+ } else {
+ warn "Can't read skip file:'$skip':$!\n";
+ $skip=[];
+ }
+ } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
+ print "Using array for skip list\n"
+ if $verbose>2;
+ } elsif ($verbose) {
+ print "No skip list found.\n"
+ if $verbose>1;
+ $skip= [];
+ }
+ warn "Got @{[0+@$skip]} skip patterns.\n"
+ if $verbose>3;
+ return $skip
+ }
+
+ =pod
+
+ =item _have_write_access
+
+ Abstract a -w check that tries to use POSIX::access() if possible.
+
+ =cut
+
+ {
+ my $has_posix;
+ sub _have_write_access {
+ my $dir=shift;
+ unless (defined $has_posix) {
+ $has_posix= (!$Is_cygwin && !$Is_Win32
+ && eval 'local $^W; require POSIX; 1') || 0;
+ }
+ if ($has_posix) {
+ return POSIX::access($dir, POSIX::W_OK());
+ } else {
+ return -w $dir;
+ }
+ }
+ }
+
+ =pod
+
+ =item _can_write_dir(C<$dir>)
+
+ Checks whether a given directory is writable, taking account
+ the possibility that the directory might not exist and would have to
+ be created first.
+
+ Returns a list, containing: C<($writable, $determined_by, @create)>
+
+ C<$writable> says whether the directory is (hypothetically) writable
+
+ C<$determined_by> is the directory the status was determined from. It will be
+ either the C<$dir>, or one of its parents.
+
+ C<@create> is a list of directories that would probably have to be created
+ to make the requested directory. It may not actually be correct on
+ relative paths with C<..> in them. But for our purposes it should work ok
+
+ =cut
+
+
+ sub _can_write_dir {
+ my $dir=shift;
+ return
+ unless defined $dir and length $dir;
+
+ my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
+ my @dirs = File::Spec->splitdir($dirs);
+ unshift @dirs, File::Spec->curdir
+ unless File::Spec->file_name_is_absolute($dir);
+
+ my $path='';
+ my @make;
+ while (@dirs) {
+ if ($Is_VMS) {
+ $dir = File::Spec->catdir($vol,@dirs);
+ }
+ else {
+ $dir = File::Spec->catdir(@dirs);
+ $dir = File::Spec->catpath($vol,$dir,'')
+ if defined $vol and length $vol;
+ }
+ next if ( $dir eq $path );
+ if ( ! -e $dir ) {
+ unshift @make,$dir;
+ next;
+ }
+ if ( _have_write_access($dir) ) {
+ return 1,$dir,@make
+ } else {
+ return 0,$dir,@make
+ }
+ } continue {
+ pop @dirs;
+ }
+ return 0;
+ }
+
+ =pod
+
+ =item _mkpath($dir,$show,$mode,$verbose,$dry_run)
+
+ Wrapper around File::Path::mkpath() to handle errors.
+
+ If $verbose is true and >1 then additional diagnostics will be produced, also
+ this will force $show to true.
+
+ If $dry_run is true then the directory will not be created but a check will be
+ made to see whether it would be possible to write to the directory, or that
+ it would be possible to create the directory.
+
+ If $dry_run is not true dies if the directory can not be created or is not
+ writable.
+
+ =cut
+
+ sub _mkpath {
+ my ($dir,$show,$mode,$verbose,$dry_run)=@_;
+ if ( $verbose && $verbose > 1 && ! -d $dir) {
+ $show= 1;
+ printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
+ }
+ if (!$dry_run) {
+ if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
+ _choke("Can't create '$dir'","$@");
+ }
+
+ }
+ my ($can,$root,@make)=_can_write_dir($dir);
+ if (!$can) {
+ my @msg=(
+ "Can't create '$dir'",
+ $root ? "Do not have write permissions on '$root'"
+ : "Unknown Error"
+ );
+ if ($dry_run) {
+ _warnonce @msg;
+ } else {
+ _choke @msg;
+ }
+ } elsif ($show and $dry_run) {
+ print "$_\n" for @make;
+ }
+
+ }
+
+ =pod
+
+ =item _copy($from,$to,$verbose,$dry_run)
+
+ Wrapper around File::Copy::copy to handle errors.
+
+ If $verbose is true and >1 then additional diagnostics will be emitted.
+
+ If $dry_run is true then the copy will not actually occur.
+
+ Dies if the copy fails.
+
+ =cut
+
+
+ sub _copy {
+ my ( $from, $to, $verbose, $dry_run)=@_;
+ if ($verbose && $verbose>1) {
+ printf "copy(%s,%s)\n", $from, $to;
+ }
+ if (!$dry_run) {
+ File::Copy::copy($from,$to)
+ or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
+ }
+ }
+
+ =pod
+
+ =item _chdir($from)
+
+ Wrapper around chdir to catch errors.
+
+ If not called in void context returns the cwd from before the chdir.
+
+ dies on error.
+
+ =cut
+
+ sub _chdir {
+ my ($dir)= @_;
+ my $ret;
+ if (defined wantarray) {
+ $ret= cwd;
+ }
+ chdir $dir
+ or _choke("Couldn't chdir to '$dir': $!");
+ return $ret;
+ }
+
+ =pod
+
+ =back
+
+ =end _private
+
+ =over
+
+ =item B<install>
+
+ # deprecated forms
+ install(\%from_to);
+ install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
+ $skip, $always_copy, \%result);
+
+ # recommended form as of 1.47
+ install([
+ from_to => \%from_to,
+ verbose => 1,
+ dry_run => 0,
+ uninstall_shadows => 1,
+ skip => undef,
+ always_copy => 1,
+ result => \%install_results,
+ ]);
+
+
+ Copies each directory tree of %from_to to its corresponding value
+ preserving timestamps and permissions.
+
+ There are two keys with a special meaning in the hash: "read" and
+ "write". These contain packlist files. After the copying is done,
+ install() will write the list of target files to $from_to{write}. If
+ $from_to{read} is given the contents of this file will be merged into
+ the written file. The read and the written file may be identical, but
+ on AFS it is quite likely that people are installing to a different
+ directory than the one where the files later appear.
+
+ If $verbose is true, will print out each file removed. Default is
+ false. This is "make install VERBINST=1". $verbose values going
+ up to 5 show increasingly more diagnostics output.
+
+ If $dry_run is true it will only print what it was going to do
+ without actually doing it. Default is false.
+
+ If $uninstall_shadows is true any differing versions throughout @INC
+ will be uninstalled. This is "make install UNINST=1"
+
+ As of 1.37_02 install() supports the use of a list of patterns to filter out
+ files that shouldn't be installed. If $skip is omitted or undefined then
+ install will try to read the list from INSTALL.SKIP in the CWD. This file is
+ a list of regular expressions and is just like the MANIFEST.SKIP file used
+ by L<ExtUtils::Manifest>.
+
+ A default site INSTALL.SKIP may be provided by setting then environment
+ variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
+ distribution specific INSTALL.SKIP. If the environment variable
+ EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
+ performed.
+
+ If $skip is undefined then the skip file will be autodetected and used if it
+ is found. If $skip is a reference to an array then it is assumed the array
+ contains the list of patterns, if $skip is a true non reference it is
+ assumed to be the filename holding the list of patterns, any other value of
+ $skip is taken to mean that no install filtering should occur.
+
+ B<Changes As of Version 1.47>
+
+ As of version 1.47 the following additions were made to the install interface.
+ Note that the new argument style and use of the %result hash is recommended.
+
+ The $always_copy parameter which when true causes files to be updated
+ regardless as to whether they have changed, if it is defined but false then
+ copies are made only if the files have changed, if it is undefined then the
+ value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
+
+ The %result hash will be populated with the various keys/subhashes reflecting
+ the install. Currently these keys and their structure are:
+
+ install => { $target => $source },
+ install_fail => { $target => $source },
+ install_unchanged => { $target => $source },
+
+ install_filtered => { $source => $pattern },
+
+ uninstall => { $uninstalled => $source },
+ uninstall_fail => { $uninstalled => $source },
+
+ where C<$source> is the filespec of the file being installed. C<$target> is where
+ it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
+ or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
+ caused a source file to be skipped. In future more keys will be added, such as to
+ show created directories, however this requires changes in other modules and must
+ therefore wait.
+
+ These keys will be populated before any exceptions are thrown should there be an
+ error.
+
+ Note that all updates of the %result are additive, the hash will not be
+ cleared before use, thus allowing status results of many installs to be easily
+ aggregated.
+
+ B<NEW ARGUMENT STYLE>
+
+ If there is only one argument and it is a reference to an array then
+ the array is assumed to contain a list of key-value pairs specifying
+ the options. In this case the option "from_to" is mandatory. This style
+ means that you do not have to supply a cryptic list of arguments and can
+ use a self documenting argument list that is easier to understand.
+
+ This is now the recommended interface to install().
+
+ B<RETURN>
+
+ If all actions were successful install will return a hashref of the results
+ as described above for the $result parameter. If any action is a failure
+ then install will die, therefore it is recommended to pass in the $result
+ parameter instead of using the return value. If the result parameter is
+ provided then the returned hashref will be the passed in hashref.
+
+ =cut
+
+ sub install { #XXX OS-SPECIFIC
+ my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
+ if (@_==1 and eval { 1+@$from_to }) {
+ my %opts = @$from_to;
+ $from_to = $opts{from_to}
+ or Carp::confess("from_to is a mandatory parameter");
+ $verbose = $opts{verbose};
+ $dry_run = $opts{dry_run};
+ $uninstall_shadows = $opts{uninstall_shadows};
+ $skip = $opts{skip};
+ $always_copy = $opts{always_copy};
+ $result = $opts{result};
+ }
+
+ $result ||= {};
+ $verbose ||= 0;
+ $dry_run ||= 0;
+
+ $skip= _get_install_skip($skip,$verbose);
+ $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY}
+ || $ENV{EU_ALWAYS_COPY}
+ || 0
+ unless defined $always_copy;
+
+ my(%from_to) = %$from_to;
+ my(%pack, $dir, %warned);
+ my($packlist) = ExtUtils::Packlist->new();
+
+ local(*DIR);
+ for (qw/read write/) {
+ $pack{$_}=$from_to{$_};
+ delete $from_to{$_};
+ }
+ my $tmpfile = install_rooted_file($pack{"read"});
+ $packlist->read($tmpfile) if (-f $tmpfile);
+ my $cwd = cwd();
+ my @found_files;
+ my %check_dirs;
+
+ MOD_INSTALL: foreach my $source (sort keys %from_to) {
+ #copy the tree to the target directory without altering
+ #timestamp and permission and remember for the .packlist
+ #file. The packlist file contains the absolute paths of the
+ #install locations. AFS users may call this a bug. We'll have
+ #to reconsider how to add the means to satisfy AFS users also.
+
+ #October 1997: we want to install .pm files into archlib if
+ #there are any files in arch. So we depend on having ./blib/arch
+ #hardcoded here.
+
+ my $targetroot = install_rooted_dir($from_to{$source});
+
+ my $blib_lib = File::Spec->catdir('blib', 'lib');
+ my $blib_arch = File::Spec->catdir('blib', 'arch');
+ if ($source eq $blib_lib and
+ exists $from_to{$blib_arch} and
+ directory_not_empty($blib_arch)
+ ){
+ $targetroot = install_rooted_dir($from_to{$blib_arch});
+ print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
+ }
+
+ next unless -d $source;
+ _chdir($source);
+ # 5.5.3's File::Find missing no_chdir option
+ # XXX OS-SPECIFIC
+ # File::Find seems to always be Unixy except on MacPerl :(
+ my $current_directory= $Is_MacPerl ? $Curdir : '.';
+ find(sub {
+ my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
+
+ return if !-f _;
+ my $origfile = $_;
+
+ return if $origfile eq ".exists";
+ my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
+ my $targetfile = File::Spec->catfile($targetdir, $origfile);
+ my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
+ my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
+
+ for my $pat (@$skip) {
+ if ( $sourcefile=~/$pat/ ) {
+ print "Skipping $targetfile (filtered)\n"
+ if $verbose>1;
+ $result->{install_filtered}{$sourcefile} = $pat;
+ return;
+ }
+ }
+ # we have to do this for back compat with old File::Finds
+ # and because the target is relative
+ my $save_cwd = _chdir($cwd);
+ my $diff = 0;
+ # XXX: I wonder how useful this logic is actually -- demerphq
+ if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
+ $diff++;
+ } else {
+ # we might not need to copy this file
+ $diff = compare($sourcefile, $targetfile);
+ }
+ $check_dirs{$targetdir}++
+ unless -w $targetfile;
+
+ push @found_files,
+ [ $diff, $File::Find::dir, $origfile,
+ $mode, $size, $atime, $mtime,
+ $targetdir, $targetfile, $sourcedir, $sourcefile,
+
+ ];
+ #restore the original directory we were in when File::Find
+ #called us so that it doesn't get horribly confused.
+ _chdir($save_cwd);
+ }, $current_directory );
+ _chdir($cwd);
+ }
+ foreach my $targetdir (sort keys %check_dirs) {
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
+ }
+ foreach my $found (@found_files) {
+ my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
+ $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
+
+ my $realtarget= $targetfile;
+ if ($diff) {
+ eval {
+ if (-f $targetfile) {
+ print "_unlink_or_rename($targetfile)\n" if $verbose>1;
+ $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
+ unless $dry_run;
+ } elsif ( ! -d $targetdir ) {
+ _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
+ }
+ print "Installing $targetfile\n";
+
+ _copy( $sourcefile, $targetfile, $verbose, $dry_run, );
+
+
+ #XXX OS-SPECIFIC
+ print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
+ utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
+
+
+ $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ $mode = $mode | 0222
+ if $realtarget ne $targetfile;
+ _chmod( $mode, $targetfile, $verbose );
+ $result->{install}{$targetfile} = $sourcefile;
+ 1
+ } or do {
+ $result->{install_fail}{$targetfile} = $sourcefile;
+ die $@;
+ };
+ } else {
+ $result->{install_unchanged}{$targetfile} = $sourcefile;
+ print "Skipping $targetfile (unchanged)\n" if $verbose;
+ }
+
+ if ( $uninstall_shadows ) {
+ inc_uninstall($sourcefile,$ffd, $verbose,
+ $dry_run,
+ $realtarget ne $targetfile ? $realtarget : "",
+ $result);
+ }
+
+ # Record the full pathname.
+ $packlist->{$targetfile}++;
+ }
+
+ if ($pack{'write'}) {
+ $dir = install_rooted_dir(dirname($pack{'write'}));
+ _mkpath( $dir, 0, 0755, $verbose, $dry_run );
+ print "Writing $pack{'write'}\n" if $verbose;
+ $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
+ }
+
+ _do_cleanup($verbose);
+ return $result;
+ }
+
+ =begin _private
+
+ =item _do_cleanup
+
+ Standardize finish event for after another instruction has occurred.
+ Handles converting $MUST_REBOOT to a die for instance.
+
+ =end _private
+
+ =cut
+
+ sub _do_cleanup {
+ my ($verbose) = @_;
+ if ($MUST_REBOOT) {
+ die _estr "Operation not completed! ",
+ "You must reboot to complete the installation.",
+ "Sorry.";
+ } elsif (defined $MUST_REBOOT & $verbose) {
+ warn _estr "Installation will be completed at the next reboot.\n",
+ "However it is not necessary to reboot immediately.\n";
+ }
+ }
+
+ =begin _undocumented
+
+ =item install_rooted_file( $file )
+
+ Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
+ is defined.
+
+ =item install_rooted_dir( $dir )
+
+ Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
+ is defined.
+
+ =end _undocumented
+
+ =cut
+
+
+ sub install_rooted_file {
+ if (defined $INSTALL_ROOT) {
+ File::Spec->catfile($INSTALL_ROOT, $_[0]);
+ } else {
+ $_[0];
+ }
+ }
+
+
+ sub install_rooted_dir {
+ if (defined $INSTALL_ROOT) {
+ File::Spec->catdir($INSTALL_ROOT, $_[0]);
+ } else {
+ $_[0];
+ }
+ }
+
+ =begin _undocumented
+
+ =item forceunlink( $file, $tryhard )
+
+ Tries to delete a file. If $tryhard is true then we will use whatever
+ devious tricks we can to delete the file. Currently this only applies to
+ Win32 in that it will try to use Win32API::File to schedule a delete at
+ reboot. A wrapper for _unlink_or_rename().
+
+ =end _undocumented
+
+ =cut
+
+
+ sub forceunlink {
+ my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
+ _unlink_or_rename( $file, $tryhard, not("installing") );
+ }
+
+ =begin _undocumented
+
+ =item directory_not_empty( $dir )
+
+ Returns 1 if there is an .exists file somewhere in a directory tree.
+ Returns 0 if there is not.
+
+ =end _undocumented
+
+ =cut
+
+ sub directory_not_empty ($) {
+ my($dir) = @_;
+ my $files = 0;
+ find(sub {
+ return if $_ eq ".exists";
+ if (-f) {
+ $File::Find::prune++;
+ $files = 1;
+ }
+ }, $dir);
+ return $files;
+ }
+
+ =pod
+
+ =item B<install_default> I<DISCOURAGED>
+
+ install_default();
+ install_default($fullext);
+
+ Calls install() with arguments to copy a module from blib/ to the
+ default site installation location.
+
+ $fullext is the name of the module converted to a directory
+ (ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
+ will attempt to read it from @ARGV.
+
+ This is primarily useful for install scripts.
+
+ B<NOTE> This function is not really useful because of the hard-coded
+ install location with no way to control site vs core vs vendor
+ directories and the strange way in which the module name is given.
+ Consider its use discouraged.
+
+ =cut
+
+ sub install_default {
+ @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
+ my $FULLEXT = @_ ? shift : $ARGV[0];
+ defined $FULLEXT or die "Do not know to where to write install log";
+ my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
+ my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
+ my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
+ my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
+ my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
+ my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
+
+ my @INST_HTML;
+ if($Config{installhtmldir}) {
+ my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
+ @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
+ }
+
+ install({
+ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
+ write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
+ $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
+ $Config{installsitearch} :
+ $Config{installsitelib},
+ $INST_ARCHLIB => $Config{installsitearch},
+ $INST_BIN => $Config{installbin} ,
+ $INST_SCRIPT => $Config{installscript},
+ $INST_MAN1DIR => $Config{installman1dir},
+ $INST_MAN3DIR => $Config{installman3dir},
+ @INST_HTML,
+ },1,0,0);
+ }
+
+
+ =item B<uninstall>
+
+ uninstall($packlist_file);
+ uninstall($packlist_file, $verbose, $dont_execute);
+
+ Removes the files listed in a $packlist_file.
+
+ If $verbose is true, will print out each file removed. Default is
+ false.
+
+ If $dont_execute is true it will only print what it was going to do
+ without actually doing it. Default is false.
+
+ =cut
+
+ sub uninstall {
+ my($fil,$verbose,$dry_run) = @_;
+ $verbose ||= 0;
+ $dry_run ||= 0;
+
+ die _estr "ERROR: no packlist file found: '$fil'"
+ unless -f $fil;
+ # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
+ # require $my_req; # Hairy, but for the first
+ my ($packlist) = ExtUtils::Packlist->new($fil);
+ foreach (sort(keys(%$packlist))) {
+ chomp;
+ print "unlink $_\n" if $verbose;
+ forceunlink($_,'tryhard') unless $dry_run;
+ }
+ print "unlink $fil\n" if $verbose;
+ forceunlink($fil, 'tryhard') unless $dry_run;
+ _do_cleanup($verbose);
+ }
+
+ =begin _undocumented
+
+ =item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
+
+ Remove shadowed files. If $ignore is true then it is assumed to hold
+ a filename to ignore. This is used to prevent spurious warnings from
+ occurring when doing an install at reboot.
+
+ We now only die when failing to remove a file that has precedence over
+ our own, when our install has precedence we only warn.
+
+ $results is assumed to contain a hashref which will have the keys
+ 'uninstall' and 'uninstall_fail' populated with keys for the files
+ removed and values of the source files they would shadow.
+
+ =end _undocumented
+
+ =cut
+
+ sub inc_uninstall {
+ my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
+ my($dir);
+ $ignore||="";
+ my $file = (File::Spec->splitpath($filepath))[2];
+ my %seen_dir = ();
+
+ my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
+ ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
+
+ my @dirs=( @PERL_ENV_LIB,
+ @INC,
+ @Config{qw(archlibexp
+ privlibexp
+ sitearchexp
+ sitelibexp)});
+
+ #warn join "\n","---",@dirs,"---";
+ my $seen_ours;
+ foreach $dir ( @dirs ) {
+ my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
+ next if $canonpath eq $Curdir;
+ next if $seen_dir{$canonpath}++;
+ my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
+ next unless -f $targetfile;
+
+ # The reason why we compare file's contents is, that we cannot
+ # know, which is the file we just installed (AFS). So we leave
+ # an identical file in place
+ my $diff = 0;
+ if ( -f $targetfile && -s _ == -s $filepath) {
+ # We have a good chance, we can skip this one
+ $diff = compare($filepath,$targetfile);
+ } else {
+ $diff++;
+ }
+ print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
+
+ if (!$diff or $targetfile eq $ignore) {
+ $seen_ours = 1;
+ next;
+ }
+ if ($dry_run) {
+ $results->{uninstall}{$targetfile} = $filepath;
+ if ($verbose) {
+ $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
+ $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
+ $Inc_uninstall_warn_handler->add(
+ File::Spec->catfile($libdir, $file),
+ $targetfile
+ );
+ }
+ # if not verbose, we just say nothing
+ } else {
+ print "Unlinking $targetfile (shadowing?)\n" if $verbose;
+ eval {
+ die "Fake die for testing"
+ if $ExtUtils::Install::Testing and
+ ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
+ forceunlink($targetfile,'tryhard');
+ $results->{uninstall}{$targetfile} = $filepath;
+ 1;
+ } or do {
+ $results->{fail_uninstall}{$targetfile} = $filepath;
+ if ($seen_ours) {
+ warn "Failed to remove probably harmless shadow file '$targetfile'\n";
+ } else {
+ die "$@\n";
+ }
+ };
+ }
+ }
+ }
+
+ =begin _undocumented
+
+ =item run_filter($cmd,$src,$dest)
+
+ Filter $src using $cmd into $dest.
+
+ =end _undocumented
+
+ =cut
+
+ sub run_filter {
+ my ($cmd, $src, $dest) = @_;
+ local(*CMD, *SRC);
+ open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
+ open(SRC, $src) || die "Cannot open $src: $!";
+ my $buf;
+ my $sz = 1024;
+ while (my $len = sysread(SRC, $buf, $sz)) {
+ syswrite(CMD, $buf, $len);
+ }
+ close SRC;
+ close CMD or die "Filter command '$cmd' failed for $src";
+ }
+
+ =pod
+
+ =item B<pm_to_blib>
+
+ pm_to_blib(\%from_to);
+ pm_to_blib(\%from_to, $autosplit_dir);
+ pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
+
+ Copies each key of %from_to to its corresponding value efficiently.
+ If an $autosplit_dir is provided, all .pm files will be autosplit into it.
+ Any destination directories are created.
+
+ $filter_cmd is an optional shell command to run each .pm file through
+ prior to splitting and copying. Input is the contents of the module,
+ output the new module contents.
+
+ You can have an environment variable PERL_INSTALL_ROOT set which will
+ be prepended as a directory to each installed file (and directory).
+
+ By default verbose output is generated, setting the PERL_INSTALL_QUIET
+ environment variable will silence this output.
+
+ =cut
+
+ sub pm_to_blib {
+ my($fromto,$autodir,$pm_filter) = @_;
+
+ _mkpath($autodir,0,0755) if defined $autodir;
+ while(my($from, $to) = each %$fromto) {
+ if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
+ print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
+ next;
+ }
+
+ # When a pm_filter is defined, we need to pre-process the source first
+ # to determine whether it has changed or not. Therefore, only perform
+ # the comparison check when there's no filter to be ran.
+ # -- RAM, 03/01/2001
+
+ my $need_filtering = defined $pm_filter && length $pm_filter &&
+ $from =~ /\.pm$/;
+
+ if (!$need_filtering && 0 == compare($from,$to)) {
+ print "Skip $to (unchanged)\n" unless $INSTALL_QUIET;
+ next;
+ }
+ if (-f $to){
+ # we wont try hard here. its too likely to mess things up.
+ forceunlink($to);
+ } else {
+ _mkpath(dirname($to),0,0755);
+ }
+ if ($need_filtering) {
+ run_filter($pm_filter, $from, $to);
+ print "$pm_filter <$from >$to\n";
+ } else {
+ _copy( $from, $to );
+ print "cp $from $to\n" unless $INSTALL_QUIET;
+ }
+ my($mode,$atime,$mtime) = (stat $from)[2,8,9];
+ utime($atime,$mtime+$Is_VMS,$to);
+ _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
+ next unless $from =~ /\.pm$/;
+ _autosplit($to,$autodir) if defined $autodir;
+ }
+ }
+
+
+ =begin _private
+
+ =item _autosplit
+
+ From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
+ the file being split. This causes problems on systems with mandatory
+ locking (ie. Windows). So we wrap it and close the filehandle.
+
+ =end _private
+
+ =cut
+
+ sub _autosplit { #XXX OS-SPECIFIC
+ my $retval = autosplit(@_);
+ close *AutoSplit::IN if defined *AutoSplit::IN{IO};
+
+ return $retval;
+ }
+
+
+ package ExtUtils::Install::Warn;
+
+ sub new { bless {}, shift }
+
+ sub add {
+ my($self,$file,$targetfile) = @_;
+ push @{$self->{$file}}, $targetfile;
+ }
+
+ sub DESTROY {
+ unless(defined $INSTALL_ROOT) {
+ my $self = shift;
+ my($file,$i,$plural);
+ foreach $file (sort keys %$self) {
+ $plural = @{$self->{$file}} > 1 ? "s" : "";
+ print "## Differing version$plural of $file found. You might like to\n";
+ for (0..$#{$self->{$file}}) {
+ print "rm ", $self->{$file}[$_], "\n";
+ $i++;
+ }
+ }
+ $plural = $i>1 ? "all those files" : "this file";
+ my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
+ ? ( $Config::Config{make} || 'make' ).' install'
+ . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
+ : './Build install uninst=1';
+ print "## Running '$inst' will unlink $plural for you.\n";
+ }
+ }
+
+ =begin _private
+
+ =item _invokant
+
+ Does a heuristic on the stack to see who called us for more intelligent
+ error messages. Currently assumes we will be called only by Module::Build
+ or by ExtUtils::MakeMaker.
+
+ =end _private
+
+ =cut
+
+ sub _invokant {
+ my @stack;
+ my $frame = 0;
+ while (my $file = (caller($frame++))[1]) {
+ push @stack, (File::Spec->splitpath($file))[2];
+ }
+
+ my $builder;
+ my $top = pop @stack;
+ if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
+ $builder = 'Module::Build';
+ } else {
+ $builder = 'ExtUtils::MakeMaker';
+ }
+ return $builder;
+ }
+
+ =pod
+
+ =back
+
+ =head1 ENVIRONMENT
+
+ =over 4
+
+ =item B<PERL_INSTALL_ROOT>
+
+ Will be prepended to each install path.
+
+ =item B<EU_INSTALL_IGNORE_SKIP>
+
+ Will prevent the automatic use of INSTALL.SKIP as the install skip file.
+
+ =item B<EU_INSTALL_SITE_SKIPFILE>
+
+ If there is no INSTALL.SKIP file in the make directory then this value
+ can be used to provide a default.
+
+ =item B<EU_INSTALL_ALWAYS_COPY>
+
+ If this environment variable is true then normal install processes will
+ always overwrite older identical files during the install process.
+
+ Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
+ is not defined until at least the 1.50 release. Please ensure you use the
+ correct EU_INSTALL_ALWAYS_COPY.
+
+ =back
+
+ =head1 AUTHOR
+
+ Original author lost in the mists of time. Probably the same as Makemaker.
+
+ Production release currently maintained by demerphq C<yves at cpan.org>,
+ extensive changes by Michael G. Schwern.
+
+ Send bug reports via http://rt.cpan.org/. Please send your
+ generated Makefile along with your report.
+
+ =head1 LICENSE
+
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+ See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+ =cut
+
+ 1;
+EXTUTILS_INSTALL
+
+$fatpacked{"ExtUtils/Installed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLED';
+ package ExtUtils::Installed;
+
+ use 5.00503;
+ use strict;
+ #use warnings; # XXX requires 5.6
+ use Carp qw();
+ use ExtUtils::Packlist;
+ use ExtUtils::MakeMaker;
+ use Config;
+ use File::Find;
+ use File::Basename;
+ use File::Spec;
+
+ my $Is_VMS = $^O eq 'VMS';
+ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
+
+ require VMS::Filespec if $Is_VMS;
+
+ use vars qw($VERSION);
+ $VERSION = '2.06';
+ $VERSION = eval $VERSION;
+
+ sub _is_prefix {
+ my ($self, $path, $prefix) = @_;
+ return unless defined $prefix && defined $path;
+
+ if( $Is_VMS ) {
+ $prefix = VMS::Filespec::unixify($prefix);
+ $path = VMS::Filespec::unixify($path);
+ }
+
+ # Unix path normalization.
+ $prefix = File::Spec->canonpath($prefix);
+
+ return 1 if substr($path, 0, length($prefix)) eq $prefix;
+
+ if ($DOSISH) {
+ $path =~ s|\\|/|g;
+ $prefix =~ s|\\|/|g;
+ return 1 if $path =~ m{^\Q$prefix\E}i;
+ }
+ return(0);
+ }
+
+ sub _is_doc {
+ my ($self, $path) = @_;
+
+ my $man1dir = $self->{':private:'}{Config}{man1direxp};
+ my $man3dir = $self->{':private:'}{Config}{man3direxp};
+ return(($man1dir && $self->_is_prefix($path, $man1dir))
+ ||
+ ($man3dir && $self->_is_prefix($path, $man3dir))
+ ? 1 : 0)
+ }
+
+ sub _is_type {
+ my ($self, $path, $type) = @_;
+ return 1 if $type eq "all";
+
+ return($self->_is_doc($path)) if $type eq "doc";
+ my $conf= $self->{':private:'}{Config};
+ if ($type eq "prog") {
+ return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
+ && !($self->_is_doc($path)) ? 1 : 0);
+ }
+ return(0);
+ }
+
+ sub _is_under {
+ my ($self, $path, @under) = @_;
+ $under[0] = "" if (! @under);
+ foreach my $dir (@under) {
+ return(1) if ($self->_is_prefix($path, $dir));
+ }
+
+ return(0);
+ }
+
+ sub _fix_dirs {
+ my ($self, @dirs)= @_;
+ # File::Find does not know how to deal with VMS filepaths.
+ if( $Is_VMS ) {
+ $_ = VMS::Filespec::unixify($_)
+ for @dirs;
+ }
+
+ if ($DOSISH) {
+ s|\\|/|g for @dirs;
+ }
+ return wantarray ? @dirs : $dirs[0];
+ }
+
+ sub _make_entry {
+ my ($self, $module, $packlist_file, $modfile)= @_;
+
+ my $data= {
+ module => $module,
+ packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
+ packlist_file => $packlist_file,
+ };
+
+ if (!$modfile) {
+ $data->{version} = $self->{':private:'}{Config}{version};
+ } else {
+ $data->{modfile} = $modfile;
+ # Find the top-level module file in @INC
+ $data->{version} = '';
+ foreach my $dir (@{$self->{':private:'}{INC}}) {
+ my $p = File::Spec->catfile($dir, $modfile);
+ if (-r $p) {
+ $module = _module_name($p, $module) if $Is_VMS;
+
+ $data->{version} = MM->parse_version($p);
+ $data->{version_from} = $p;
+ $data->{packlist_valid} = exists $data->{packlist}{$p};
+ last;
+ }
+ }
+ }
+ $self->{$module}= $data;
+ }
+
+ our $INSTALLED;
+ sub new {
+ my ($class) = shift(@_);
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
+
+ my $self = bless {}, $class;
+
+ $INSTALLED= $self if $args{default_set} || $args{default};
+
+
+ if ($args{config_override}) {
+ eval {
+ $self->{':private:'}{Config} = { %{$args{config_override}} };
+ } or Carp::croak(
+ "The 'config_override' parameter must be a hash reference."
+ );
+ }
+ else {
+ $self->{':private:'}{Config} = \%Config;
+ }
+
+ for my $tuple ([inc_override => INC => [ @INC ] ],
+ [ extra_libs => EXTRA => [] ])
+ {
+ my ($arg,$key,$val)=@$tuple;
+ if ( $args{$arg} ) {
+ eval {
+ $self->{':private:'}{$key} = [ @{$args{$arg}} ];
+ } or Carp::croak(
+ "The '$arg' parameter must be an array reference."
+ );
+ }
+ elsif ($val) {
+ $self->{':private:'}{$key} = $val;
+ }
+ }
+ {
+ my %dupe;
+ @{$self->{':private:'}{LIBDIRS}} =
+ grep { $_ ne '.' || ! $args{skip_cwd} }
+ grep { -e $_ && !$dupe{$_}++ }
+ @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
+ }
+
+ my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
+
+ # Read the core packlist
+ my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
+ $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
+
+ my $root;
+ # Read the module packlists
+ my $sub = sub {
+ # Only process module .packlists
+ return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
+
+ # Hack of the leading bits of the paths & convert to a module name
+ my $module = $File::Find::name;
+ my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
+ or do {
+ # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
+ # join ("\n",@dirs);
+ return;
+ };
+
+ my $modfile = "$module.pm";
+ $module =~ s!/!::!g;
+
+ return if $self->{$module}; #shadowing?
+ $self->_make_entry($module,$File::Find::name,$modfile);
+ };
+ while (@dirs) {
+ $root= shift @dirs;
+ next if !-d $root;
+ find($sub,$root);
+ }
+
+ return $self;
+ }
+
+ # VMS's non-case preserving file-system means the package name can't
+ # be reconstructed from the filename.
+ sub _module_name {
+ my($file, $orig_module) = @_;
+
+ my $module = '';
+ if (open PACKFH, $file) {
+ while (<PACKFH>) {
+ if (/package\s+(\S+)\s*;/) {
+ my $pack = $1;
+ # Make a sanity check, that lower case $module
+ # is identical to lowercase $pack before
+ # accepting it
+ if (lc($pack) eq lc($orig_module)) {
+ $module = $pack;
+ last;
+ }
+ }
+ }
+ close PACKFH;
+ }
+
+ print STDERR "Couldn't figure out the package name for $file\n"
+ unless $module;
+
+ return $module;
+ }
+
+ sub modules {
+ my ($self) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+
+ # Bug/feature of sort in scalar context requires this.
+ return wantarray
+ ? sort grep { not /^:private:$/ } keys %$self
+ : grep { not /^:private:$/ } keys %$self;
+ }
+
+ sub files {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+
+ # Validate arguments
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ $type = "all" if (! defined($type));
+ Carp::croak('type must be "all", "prog" or "doc"')
+ if ($type ne "all" && $type ne "prog" && $type ne "doc");
+
+ my (@files);
+ foreach my $file (keys(%{$self->{$module}{packlist}})) {
+ push(@files, $file)
+ if ($self->_is_type($file, $type) &&
+ $self->_is_under($file, @under));
+ }
+ return(@files);
+ }
+
+ sub directories {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ my (%dirs);
+ foreach my $file ($self->files($module, $type, @under)) {
+ $dirs{dirname($file)}++;
+ }
+ return sort keys %dirs;
+ }
+
+ sub directory_tree {
+ my ($self, $module, $type, @under) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ my (%dirs);
+ foreach my $dir ($self->directories($module, $type, @under)) {
+ $dirs{$dir}++;
+ my ($last) = ("");
+ while ($last ne $dir) {
+ $last = $dir;
+ $dir = dirname($dir);
+ last if !$self->_is_under($dir, @under);
+ $dirs{$dir}++;
+ }
+ }
+ return(sort(keys(%dirs)));
+ }
+
+ sub validate {
+ my ($self, $module, $remove) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist}->validate($remove));
+ }
+
+ sub packlist {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist});
+ }
+
+ sub version {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{version});
+ }
+
+ sub debug_dump {
+ my ($self, $module) = @_;
+ $self= $self->new(default=>1) if !ref $self;
+ local $self->{":private:"}{Config};
+ require Data::Dumper;
+ print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
+ }
+
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ ExtUtils::Installed - Inventory management of installed modules
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::Installed;
+ my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
+ my (@modules) = $inst->modules();
+ my (@missing) = $inst->validate("DBI");
+ my $all_files = $inst->files("DBI");
+ my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
+ my $all_dirs = $inst->directories("DBI");
+ my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
+ my $packlist = $inst->packlist("DBI");
+
+ =head1 DESCRIPTION
+
+ ExtUtils::Installed provides a standard way to find out what core and module
+ files have been installed. It uses the information stored in .packlist files
+ created during installation to provide this information. In addition it
+ provides facilities to classify the installed files and to extract directory
+ information from the .packlist files.
+
+ =head1 USAGE
+
+ The new() function searches for all the installed .packlists on the system, and
+ stores their contents. The .packlists can be queried with the functions
+ described below. Where it searches by default is determined by the settings found
+ in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
+
+ =head1 METHODS
+
+ Unless specified otherwise all method can be called as class methods, or as object
+ methods. If called as class methods then the "default" object will be used, and if
+ necessary created using the current processes %Config and @INC. See the
+ 'default' option to new() for details.
+
+
+ =over 4
+
+ =item new()
+
+ This takes optional named parameters. Without parameters, this
+ searches for all the installed .packlists on the system using
+ information from C<%Config::Config> and the default module search
+ paths C<@INC>. The packlists are read using the
+ L<ExtUtils::Packlist> module.
+
+ If the named parameter C<skip_cwd> is true, the current directory C<.> will
+ be stripped from C<@INC> before searching for .packlists. This keeps
+ ExtUtils::Installed from finding modules installed in other perls that
+ happen to be located below the current directory.
+
+ If the named parameter C<config_override> is specified,
+ it should be a reference to a hash which contains all information
+ usually found in C<%Config::Config>. For example, you can obtain
+ the configuration information for a separate perl installation and
+ pass that in.
+
+ my $yoda_cfg = get_fake_config('yoda');
+ my $yoda_inst =
+ ExtUtils::Installed->new(config_override=>$yoda_cfg);
+
+ Similarly, the parameter C<inc_override> may be a reference to an
+ array which is used in place of the default module search paths
+ from C<@INC>.
+
+ use Config;
+ my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
+ my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
+
+ B<Note>: You probably do not want to use these options alone, almost always
+ you will want to set both together.
+
+ The parameter C<extra_libs> can be used to specify B<additional> paths to
+ search for installed modules. For instance
+
+ my $installed =
+ ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
+
+ This should only be necessary if F</my/lib/path> is not in PERL5LIB.
+
+ Finally there is the 'default', and the related 'default_get' and 'default_set'
+ options. These options control the "default" object which is provided by the
+ class interface to the methods. Setting C<default_get> to true tells the constructor
+ to return the default object if it is defined. Setting C<default_set> to true tells
+ the constructor to make the default object the constructed object. Setting the
+ C<default> option is like setting both to true. This is used primarily internally
+ and probably isn't interesting to any real user.
+
+ =item modules()
+
+ This returns a list of the names of all the installed modules. The perl 'core'
+ is given the special name 'Perl'.
+
+ =item files()
+
+ This takes one mandatory parameter, the name of a module. It returns a list of
+ all the filenames from the package. To obtain a list of core perl files, use
+ the module name 'Perl'. Additional parameters are allowed. The first is one
+ of the strings "prog", "doc" or "all", to select either just program files,
+ just manual files or all files. The remaining parameters are a list of
+ directories. The filenames returned will be restricted to those under the
+ specified directories.
+
+ =item directories()
+
+ This takes one mandatory parameter, the name of a module. It returns a list of
+ all the directories from the package. Additional parameters are allowed. The
+ first is one of the strings "prog", "doc" or "all", to select either just
+ program directories, just manual directories or all directories. The remaining
+ parameters are a list of directories. The directories returned will be
+ restricted to those under the specified directories. This method returns only
+ the leaf directories that contain files from the specified module.
+
+ =item directory_tree()
+
+ This is identical in operation to directories(), except that it includes all the
+ intermediate directories back up to the specified directories.
+
+ =item validate()
+
+ This takes one mandatory parameter, the name of a module. It checks that all
+ the files listed in the modules .packlist actually exist, and returns a list of
+ any missing files. If an optional second argument which evaluates to true is
+ given any missing files will be removed from the .packlist
+
+ =item packlist()
+
+ This returns the ExtUtils::Packlist object for the specified module.
+
+ =item version()
+
+ This returns the version number for the specified module.
+
+ =back
+
+ =head1 EXAMPLE
+
+ See the example in L<ExtUtils::Packlist>.
+
+ =head1 AUTHOR
+
+ Alan Burlison <Alan.Burlison@uk.sun.com>
+
+ =cut
+EXTUTILS_INSTALLED
+
$fatpacked{"ExtUtils/Liblist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST';
package ExtUtils::Liblist;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
use File::Spec;
@@ -37413,7 +39259,7 @@ $fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
use strict;
use warnings;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
use ExtUtils::MakeMaker::Config;
@@ -37740,7 +39586,7 @@ $fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
$libs_seen{$fullname} = 1 if $path; # why is this a special case?
}
- my @libs = keys %libs_seen;
+ my @libs = sort keys %libs_seen;
return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
@@ -38053,7 +39899,7 @@ $fatpacked{"ExtUtils/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXT
use strict;
use ExtUtils::MakeMaker::Config;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::Liblist;
@@ -38145,9 +39991,10 @@ $fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_AIX;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
+ use ExtUtils::MakeMaker::Config;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
@@ -38178,13 +40025,7 @@ $fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub dlsyms {
my($self,%attribs) = @_;
return '' unless $self->needs_linking;
- my @m;
- # these will need XSMULTI-fying but maybe that already happens
- push @m,"\ndynamic :: $self->{BASEEXT}.exp\n\n"
- unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
- push @m,"\nstatic :: $self->{BASEEXT}.exp\n\n"
- unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
- join "\n", @m, $self->xs_dlsyms_iterator(\%attribs);
+ join "\n", $self->xs_dlsyms_iterator(\%attribs);
}
=head3 xs_dlsyms_ext
@@ -38197,6 +40038,21 @@ $fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
'.exp';
}
+ sub xs_dlsyms_arg {
+ my($self, $file) = @_;
+ return qq{-bE:${file}};
+ }
+
+ sub init_others {
+ my $self = shift;
+ $self->SUPER::init_others;
+ # perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out
+ # so right value can be added by xs_make_dynamic_lib to work for XSMULTI
+ $self->{LDDLFLAGS} ||= $Config{lddlflags};
+ $self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#;
+ return;
+ }
+
=head1 AUTHOR
Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix
@@ -38215,7 +40071,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_Any;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
use Carp;
@@ -38224,7 +40080,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
BEGIN { our @ISA = qw(File::Spec); }
# We need $Verbose
- use ExtUtils::MakeMaker qw($Verbose write_file_via_tmp neatvalue _sprintf562);
+ use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562);
use ExtUtils::MakeMaker::Config;
@@ -38232,12 +40088,10 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
- my $Rootdir = __PACKAGE__->rootdir;
- my $Updir = __PACKAGE__->updir;
+ #my $Updir = __PACKAGE__->updir;
my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec';
my $METASPEC_V = 2;
- my $STASHDIR = File::Spec->catdir('blib', '_eumm');
=head1 NAME
@@ -38590,16 +40444,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub stashmeta {
my($self, $text, $file) = @_;
- require File::Path;
- -d $STASHDIR or die "$STASHDIR: $!" unless File::Path::mkpath($STASHDIR,0,0777);
- my $stashfile = File::Spec->catfile($STASHDIR, $file);
- write_file_via_tmp($stashfile, [ $text ]);
- my $qlfile = $self->quote_literal($file);
- my $qlstashfile = $self->quote_literal($stashfile);
- (
- sprintf('-$(NOECHO) $(RM_F) %s', $qlfile),
- sprintf('-$(NOECHO) $(CP) %s %s', $qlstashfile, $qlfile),
- );
+ $self->echo($text, $file, { allow_variables => 0, append => 0 });
}
@@ -38939,7 +40784,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $file = $_;
map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base);
} $self->_xs_list_basenames;
- my @dirs = qw(blib _eumm);
+ my @dirs = qw(blib);
# Normally these are all under blib but they might have been
# redefined.
@@ -39135,6 +40980,17 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
+ =head3 xs_dlsyms_arg
+
+ Returns command-line arg(s) to linker for file listing dlsyms to export.
+ Defaults to returning empty string, can be overridden by e.g. AIX.
+
+ =cut
+
+ sub xs_dlsyms_arg {
+ return '';
+ }
+
=head3 xs_dlsyms_ext
Returns file-extension for C<xs_make_dlsyms> method's output file,
@@ -39250,7 +41106,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my($self) = shift;
'
- dynamic :: $(FIRST_MAKEFILE) $(INST_BOOT) $(INST_DYNAMIC)
+ dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC)
$(NOECHO) $(NOOP)
';
}
@@ -39316,12 +41172,16 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
return $manify;
}
- sub _has_cpan_meta {
- return eval {
- require CPAN::Meta;
- CPAN::Meta->VERSION(2.112150);
- 1;
- };
+ {
+ my $has_cpan_meta;
+ sub _has_cpan_meta {
+ return $has_cpan_meta if defined $has_cpan_meta;
+ return $has_cpan_meta = !!eval {
+ require CPAN::Meta;
+ CPAN::Meta->VERSION(2.112150);
+ 1;
+ };
+ }
}
=head3 metafile_target
@@ -39539,8 +41399,10 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# needs to be based on the original version
my $v1_add = _metaspec_version($meta_add) !~ /^2/;
+ my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge;
for my $frag ($meta_add, $meta_merge) {
- $frag = CPAN::Meta::Converter->new($frag, default_version => "1.4")->upgrade_fragment;
+ my $def_v = $frag == $meta_add ? $merge_v : $add_v;
+ $frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment;
}
# if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that
@@ -41018,38 +42880,50 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $tests = $mm->find_tests_recursive;
Returns a string suitable for feeding to the shell to return all
- tests in t/ but recursively.
+ tests in t/ but recursively. Equivalent to
+
+ my $tests = $mm->find_tests_recursive_in('t');
=cut
sub find_tests_recursive {
- my($self) = shift;
- return '' unless -d 't';
+ my $self = shift;
+ return $self->find_tests_recursive_in('t');
+ }
+
+ =head3 find_tests_recursive_in
+
+ my $tests = $mm->find_tests_recursive_in($dir);
+
+ Returns a string suitable for feeding to the shell to return all
+ tests in $dir recursively.
+
+ =cut
+
+ sub find_tests_recursive_in {
+ my($self, $dir) = @_;
+ return '' unless -d $dir;
require File::Find;
- my %testfiles;
+ my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] );
+ my %depths;
my $wanted = sub {
return unless m!\.t$!;
my ($volume,$directories,$file) =
File::Spec->splitpath( $File::Find::name );
- my @dirs = File::Spec->splitdir( $directories );
- for ( @dirs ) {
- next if $_ eq 't';
- unless ( $_ ) {
- $_ = '*.t';
- next;
- }
- $_ = '*';
- }
- my $testfile = join '/', @dirs;
- $testfiles{ $testfile } = 1;
+ my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories );
+ $depth -= $base_depth;
+ $depths{ $depth } = 1;
};
- File::Find::find( $wanted, 't' );
+ File::Find::find( $wanted, $dir );
- return join ' ', sort keys %testfiles;
+ return join ' ',
+ map { $dir . '/*' x $_ . '.t' }
+ sort { $a <=> $b }
+ keys %depths;
}
=head3 extra_clean_files
@@ -41317,7 +43191,7 @@ $fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
@@ -41366,7 +43240,7 @@ $fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
@@ -41444,7 +43318,7 @@ $fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
if ($Config{useshrplib} eq 'true') {
my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
if( $] >= 5.006002 ) {
- $libperl =~ s/a$/dll.a/;
+ $libperl =~ s/(dll\.)?a$/dll.a/;
}
$self->{PERL_ARCHIVE} = $libperl;
} else {
@@ -41537,7 +43411,7 @@ $fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
@@ -41611,7 +43485,7 @@ $fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
our @ISA = qw( ExtUtils::MM_Unix );
}
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
@@ -41657,7 +43531,7 @@ $fatpacked{"ExtUtils/MM_MacOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
sub new {
@@ -41714,7 +43588,7 @@ $fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use ExtUtils::MakeMaker::Config;
use File::Basename;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
@@ -41900,7 +43774,7 @@ $fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
@@ -41949,7 +43823,8 @@ $fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# Make import files (needed for static build)
-d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
- while (my($name, $exp) = each %{$self->{IMPORTS}}) {
+ foreach my $name (sort keys %{$self->{IMPORTS}}) {
+ my $exp = $self->{IMPORTS}->{$name};
my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
print $imp "$name $lib $id ?\n";
}
@@ -42036,7 +43911,7 @@ $fatpacked{"ExtUtils/MM_QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_QNX;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
@@ -42097,7 +43972,7 @@ $fatpacked{"ExtUtils/MM_UWIN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
package ExtUtils::MM_UWIN;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
@@ -42171,7 +44046,6 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
use Carp;
use ExtUtils::MakeMaker::Config;
use File::Basename qw(basename dirname);
- use DirHandle;
our %Config_Override;
@@ -42179,7 +44053,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
- $VERSION = '7.06';
+ $VERSION = '7.30';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
require ExtUtils::MM_Any;
@@ -42262,7 +44136,6 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# So we don't have to keep calling the methods over and over again,
# we have these globals to cache the values. Faster and shrtr.
my $Curdir = __PACKAGE__->curdir;
- my $Rootdir = __PACKAGE__->rootdir;
my $Updir = __PACKAGE__->updir;
@@ -42307,7 +44180,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
};
}
- push @m, sprintf <<'EOF', $command, $flags, $self->xs_obj_opt('$*.s');
+ my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : '';
+ push @m, sprintf <<'EOF', $command, $flags, $m_o;
.c.s :
%s -S %s $*.c %s
@@ -42315,9 +44189,9 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my @exts = qw(c cpp cxx cc);
push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
- my $oo = $self->xs_obj_opt('$*$(OBJ_EXT)');
+ $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
for my $ext (@exts) {
- push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext $oo\n";
+ push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
}
return join "", @m;
}
@@ -42630,7 +44504,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
push @m, q{
# Where is the Config information that we are using/depend on
CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
- } if -e File::Spec->catfile( $self->{PERL_INC}, 'config.h' );
+ } if -e $self->catfile( $self->{PERL_INC}, 'config.h' );
push @m, qq{
@@ -42840,7 +44714,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub dist_ci {
my($self) = shift;
return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]);
- @all = keys %{ maniread() };
+ @all = sort keys %{ maniread() };
print(qq{Executing $(CI) @all\n});
system(qq{$(CI) @all}) == 0 or die $!;
print(qq{Executing $(RCS_LABEL) ...\n});
@@ -43062,9 +44936,9 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my ($v, $d, $f) = File::Spec->splitpath($basename);
my @d = File::Spec->splitdir($d);
shift @d if $self->{XSMULTI} and $d[0] eq 'lib';
- my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
$instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)';
- my $instfile = File::Spec->catfile($instdir, "$f.bs");
+ my $instfile = $self->catfile($instdir, "$f.bs");
my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target
# 1 2 3
return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists;
@@ -43097,23 +44971,35 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
return '' unless $self->has_link_code;
my @m = $self->xs_dynamic_lib_macros(\%attribs);
my @libs;
+ my $dlsyms_ext = eval { $self->xs_dlsyms_ext };
if ($self->{XSMULTI}) {
my @exts = $self->_xs_list_basenames;
for my $ext (@exts) {
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
- my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
- my $instfile = File::Spec->catfile($instdir, "$f.\$(DLEXT)");
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+
+ # Dynamic library names may need special handling.
+ eval { require DynaLoader };
+ if (defined &DynaLoader::mod2fname) {
+ $f = &DynaLoader::mod2fname([@d, $f]);
+ }
+
+ my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)");
my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT');
$objfile = "$ext\$(OBJ_EXT)" unless defined $objfile;
my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM');
$ldfrom = $objfile unless defined $ldfrom;
my $exportlist = "$ext.def";
- push @libs, [ $objfile, $instfile, $instdir, $ldfrom, $exportlist ];
+ my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist);
+ push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef;
+ push @libs, \@libchunk;
}
} else {
- @libs = ([ qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)) ]);
+ my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST));
+ push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef;
+ @libs = (\@libchunk);
}
push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs;
@@ -43157,10 +45043,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
=cut
sub xs_make_dynamic_lib {
- my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist) = @_;
+ my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_;
$exportlist = '' if $exportlist ne '$(EXPORT_LIST)';
my $armaybe = $self->_xs_armaybe($attribs);
- my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)'."\n", $to, $object, $todir, $exportlist;
+ my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || '');
+ my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms);
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
push(@m," \$(ARMAYBE) cr $ldfrom $object\n");
@@ -43201,8 +45088,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
}
- push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist;
- %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
+ push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist;
+ %s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \
$(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \
$(INST_DYNAMIC_FIX)
$(CHMOD) $(PERM_RWX) $@
@@ -43268,21 +45155,26 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
}
foreach my $name (@$names){
- foreach my $dir (@$dirs){
+ my ($abs, $use_dir);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq
+ $self->canonpath(basename($name))) { # foo
+ $use_dir = 1;
+ } else { # foo/bar
+ $abs = $self->catfile($Curdir, $name);
+ }
+ foreach my $dir ($use_dir ? @$dirs : 1){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
- my ($abs, $val);
- if ($self->file_name_is_absolute($name)) { # /foo/bar
- $abs = $name;
- } elsif ($self->canonpath($name) eq
- $self->canonpath(basename($name))) { # foo
- $abs = File::Spec->catfile($dir, $name);
- } else { # foo/bar
- $abs = File::Spec->catfile($Curdir, $name);
- }
+
+ $abs = $self->catfile($dir, $name)
+ if $use_dir;
+
print "Checking $abs\n" if ($trace >= 2);
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
+ my $val;
my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"};
# To avoid using the unportable 2>&1 to suppress STDERR,
@@ -43410,7 +45302,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$interpreter = '';
foreach my $dir (@absdirs) {
- my $maybefile = File::Spec->catfile($dir,$cmd);
+ my $maybefile = $self->catfile($dir,$cmd);
if ( $self->maybe_command($maybefile) ) {
warn "Ignoring $interpreter in $file\n"
if $Verbose && $interpreter;
@@ -43535,7 +45427,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
if (-d $name){
next if -l $name; # We do not support symlinks at all
next if $self->{NORECURS};
- $dir{$name} = $name if (-f File::Spec->catfile($name,"Makefile.PL"));
+ $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
} elsif ($name =~ /\.xs\z/){
my($c); ($c = $name) =~ s/\.xs\z/.c/;
$xs{$name} = $c;
@@ -43555,10 +45447,10 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
}
else {
- $pm{$name} = File::Spec->catfile($self->{INST_LIBDIR},$name);
+ $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
} elsif ($name =~ /\.(p[ml]|pod)\z/){
- $pm{$name} = File::Spec->catfile($self->{INST_LIBDIR},$name);
+ $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
}
}
@@ -43635,7 +45527,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
next unless $self->_has_pod($name);
$self->{MAN1PODS}->{$name} =
- File::Spec->catfile("\$(INST_MAN1DIR)",
+ $self->catfile("\$(INST_MAN1DIR)",
basename($name).".\$(MAN1EXT)");
}
}
@@ -43672,7 +45564,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
foreach my $name (keys %manifypods) {
if (
($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or
- ( $name eq 'README.pod') # don't manify top-level README.pod
+ ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod
) {
delete $manifypods{$name};
next;
@@ -43681,13 +45573,13 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$manpagename =~ s/\.p(od|m|l)\z//;
# everything below lib is ok
unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
- $manpagename = File::Spec->catfile(
+ $manpagename = $self->catfile(
split(/::/,$self->{PARENT_NAME}),$manpagename
);
}
$manpagename = $self->replace_manpage_separator($manpagename);
$self->{MAN3PODS}->{$name} =
- File::Spec->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
+ $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
}
}
@@ -43779,7 +45671,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
{$1}i;
- my($inst) = File::Spec->catfile($prefix,$striplibpath);
+ my($inst) = $self->catfile($prefix,$striplibpath);
local($_) = $inst; # for backwards compatibility
$inst = $self->libscan($inst);
print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
@@ -43833,7 +45725,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
### Only UNIX:
### ($self->{FULLEXT} =
### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
- $self->{FULLEXT} = File::Spec->catdir(split /::/, $self->{NAME});
+ $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
# Copied from DynaLoader:
@@ -43869,11 +45761,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
unless ($self->{PERL_SRC}){
foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
- my $dir = File::Spec->catdir(($Updir) x $dir_count);
+ my $dir = $self->catdir(($Updir) x $dir_count);
- if (-f File::Spec->catfile($dir,"config_h.SH") &&
- -f File::Spec->catfile($dir,"perl.h") &&
- -f File::Spec->catfile($dir,"lib","strict.pm")
+ if (-f $self->catfile($dir,"config_h.SH") &&
+ -f $self->catfile($dir,"perl.h") &&
+ -f $self->catfile($dir,"lib","strict.pm")
) {
$self->{PERL_SRC}=$dir ;
last;
@@ -43885,19 +45777,19 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$self->{PERL_CORE} and !$self->{PERL_SRC};
if ($self->{PERL_SRC}){
- $self->{PERL_LIB} ||= File::Spec->catdir("$self->{PERL_SRC}","lib");
+ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
$self->{PERL_ARCHLIB} = $self->{PERL_LIB};
$self->{PERL_INC} = ($Is{Win32}) ?
- File::Spec->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
+ $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
# catch a situation that has occurred a few times in the past:
unless (
- -s File::Spec->catfile($self->{PERL_SRC},'cflags')
+ -s $self->catfile($self->{PERL_SRC},'cflags')
or
$Is{VMS}
&&
- -s File::Spec->catfile($self->{PERL_SRC},'vmsish.h')
+ -s $self->catfile($self->{PERL_SRC},'vmsish.h')
or
$Is{Win32}
){
@@ -43920,23 +45812,23 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
$self->{PERL_LIB} ||= $Config{privlibexp};
$self->{PERL_ARCHLIB} ||= $Config{archlibexp};
- $self->{PERL_INC} = File::Spec->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
+ $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
my $perl_h;
- if (not -f ($perl_h = File::Spec->catfile($self->{PERL_INC},"perl.h"))
+ if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
and not $old){
# Maybe somebody tries to build an extension with an
# uninstalled Perl outside of Perl build tree
my $lib;
for my $dir (@INC) {
- $lib = $dir, last if -e File::Spec->catfile($dir, "Config.pm");
+ $lib = $dir, last if -e $self->catfile($dir, "Config.pm");
}
if ($lib) {
# Win32 puts its header files in /perl/src/lib/CORE.
# Unix leaves them in /perl/src.
- my $inc = $Is{Win32} ? File::Spec->catdir($lib, "CORE" )
+ my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
: dirname $lib;
- if (-e File::Spec->catfile($inc, "perl.h")) {
+ if (-e $self->catfile($inc, "perl.h")) {
$self->{PERL_LIB} = $lib;
$self->{PERL_ARCHLIB} = $lib;
$self->{PERL_INC} = $inc;
@@ -44007,7 +45899,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# make a simple check if we find strict
warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
(strict.pm not found)"
- unless -f File::Spec->catfile("$self->{PERL_LIB}","strict.pm") ||
+ unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
$self->{NAME} eq "ExtUtils::MakeMaker";
}
@@ -44218,7 +46110,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# Make sure perl can find itself before it's installed.
my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE}
- ? $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ?
+ ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ?
q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"}
: undef;
my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB}
@@ -44303,11 +46195,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
if ($self->has_link_code()) {
$self->{INST_STATIC} =
- File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
$self->{INST_DYNAMIC} =
- File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
$self->{INST_BOOT} =
- File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
+ $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
if ($self->{XSMULTI}) {
my @exts = $self->_xs_list_basenames;
my (@statics, @dynamics, @boots);
@@ -44315,10 +46207,18 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my ($v, $d, $f) = File::Spec->splitpath($ext);
my @d = File::Spec->splitdir($d);
shift @d if defined $d[0] and $d[0] eq 'lib';
- my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
- my $instfile = File::Spec->catfile($instdir, $f);
+ my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f);
+ my $instfile = $self->catfile($instdir, $f);
push @statics, "$instfile\$(LIB_EXT)";
- push @dynamics, "$instfile.\$(DLEXT)";
+
+ # Dynamic library names may need special handling.
+ my $dynfile = $instfile;
+ eval { require DynaLoader };
+ if (defined &DynaLoader::mod2fname) {
+ $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f]));
+ }
+
+ push @dynamics, "$dynfile.\$(DLEXT)";
push @boots, "$instfile.bs";
}
$self->{INST_STATIC} = join ' ', @statics;
@@ -44372,8 +46272,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
};
push @m,
- q{ read "}.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
- write "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
+ q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
@@ -44384,15 +46284,15 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
"$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- "}.File::Spec->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{"
+ "}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{"
pure_site_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
- q{ read "}.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
- write "}.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
+ q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
@@ -44403,14 +46303,14 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
"$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \
"$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- "}.File::Spec->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{"
+ "}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{"
pure_vendor_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
- q{ read "}.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
- write "}.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
+ q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
@@ -44445,7 +46345,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_site_install :: all
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
@@ -44456,7 +46356,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_vendor_install :: all
$(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
@@ -44467,7 +46367,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
} unless $self->{NO_PERLLOCAL};
@@ -44476,13 +46376,13 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
- $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{"
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_sitedirs ::
- $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_vendordirs ::
- $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
};
join("",@m);
@@ -44505,7 +46405,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my %fromto;
for my $from (@exefiles) {
- my($path)= File::Spec->catfile('$(INST_SCRIPT)', basename($from));
+ my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
local($_) = $path; # for backwards compatibility
my $to = $self->libscan($path);
@@ -44577,14 +46477,13 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
=cut
sub lsdir {
- my($self) = shift;
- my($dir, $regex) = @_;
- my(@ls);
- my $dh = new DirHandle;
- $dh->open($dir || ".") or return ();
- @ls = $dh->read;
- $dh->close;
- @ls = grep(/$regex/, @ls) if $regex;
+ # $self
+ my(undef, $dir, $regex) = @_;
+ opendir(my $dh, defined($dir) ? $dir : ".")
+ or return;
+ my @ls = readdir $dh;
+ closedir $dh;
+ @ls = grep(/$regex/, @ls) if defined $regex;
@ls;
}
@@ -44597,9 +46496,9 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub macro {
my($self,%attribs) = @_;
- my(@m,$key,$val);
- while (($key,$val) = each %attribs){
- last unless defined $key;
+ my @m;
+ foreach my $key (sort keys %attribs) {
+ my $val = $attribs{$key};
push @m, "$key = $val\n";
}
join "", @m;
@@ -44645,12 +46544,12 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
foreach (@ARGV){
- if( /\s/ ){
- s/=(.*)/='$1'/;
+ my $arg = $_; # avoid lvalue aliasing
+ if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) {
+ $arg = $1 . $self->quote_literal($2);
}
- push @m, " \\\n\t\t$_";
+ push @m, " \\\n\t\t$arg";
}
- # push @m, map( " \\\n\t\t$_", @ARGV );
push @m, "\n";
return join '', @m;
@@ -44677,8 +46576,18 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}"
);
File::Find::find(sub {
+ if ($File::Find::name =~ m{/auto/share\z}) {
+ # in a subdir of auto/share, prune because e.g.
+ # Alien::pkgconfig uses File::ShareDir to put .a files
+ # there. do not want
+ $File::Find::prune = 1;
+ return;
+ }
+
return unless m/\Q$self->{LIB_EXT}\E$/;
+ return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation
+
# Skip perl's libraries.
return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
@@ -44724,7 +46633,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
return if $File::Find::name =~ m:\Q$installed_version\E\z:;
use Cwd 'cwd';
$static{cwd() . "/" . $_}++;
- }, grep( -d $_, @{$searchdirs || []}) );
+ }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) );
# We trust that what has been handed in as argument, will be buildable
$static = [] unless $static;
@@ -44804,7 +46713,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)';
# 1 2 3 4
- push @m, _sprintf562 <<'EOF', $tmp, $self->xs_obj_opt('$@'), $ldfrom, $makefilename;
+ push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename;
$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all
$(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS)
$(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call"
@@ -44838,7 +46747,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
MAP_STATIC "$(MAP_STATIC)" \
MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
MAP_LIBPERL "$(MAP_LIBPERL)" \
- >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
};
@@ -44846,7 +46755,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
inst_perl : pure_inst_perl doc_inst_perl
pure_inst_perl : $(MAP_TARGET)
- }.$self->{CP}.q{ $(MAP_TARGET) "}.File::Spec->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{"
+ }.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{"
clean :: map_clean
@@ -45027,7 +46936,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
next if $inpod || /^\s*#/;
chop;
next if /^\s*(if|unless|elsif)/;
- if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ; }x ) {
+ if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) {
local $^W = 0;
$result = $1;
}
@@ -45106,7 +47015,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $val = qq{\$($key)};
# expand within perl if given since need to use quote_literal
# since INC might include space-protecting ""!
- $val = $self->{$key} if defined $self->{$key};
+ chomp($val = $self->{$key}) if defined $self->{$key};
$val .= " \$(PASTHRU_$key)";
my $quoted = $self->quote_literal($val);
push @pasthru, qq{PASTHRU_$key=$quoted};
@@ -45178,7 +47087,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub pm_to_blib {
my $self = shift;
- my($autodir) = File::Spec->catdir('$(INST_LIB)','auto');
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
my $r = q{
pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
};
@@ -45355,7 +47264,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
warn " cannot prefix, using default.\n" if $Verbose >= 2;
warn " no default!\n" if !$default && $Verbose >= 2;
- $path = File::Spec->catdir($rprefix, $default) if $default;
+ $path = $self->catdir($rprefix, $default) if $default;
}
print " now $path\n" if $Verbose >= 2;
@@ -45405,7 +47314,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$m .= <<MAKE_FRAG;
- all :: $target
+ pure_all :: $target
\$(NOECHO) \$(NOOP)
$target :: $plfile $pm_dep
@@ -45688,7 +47597,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# And as it's not yet built, we add the current extension
# but only if it has some C code (or XS code, which implies C code)
if (@{$self->{C}}) {
- @static = File::Spec->catfile($self->{INST_ARCHLIB},
+ @static = $self->catfile($self->{INST_ARCHLIB},
"auto",
$self->{FULLEXT},
"$self->{BASEEXT}$self->{LIB_EXT}"
@@ -45805,7 +47714,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
EOF
for my $linktype (qw(dynamic static)) {
- push @m, "subdirs-test_$linktype :: $linktype pure_all\n";
+ my $directdeps = join ' ', grep !$self->{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped
+ push @m, "subdirs-test_$linktype :: $directdeps\n";
foreach my $dir (@{ $self->{DIR} }) {
my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)");
push @m, "\t\$(NOECHO) $test\n";
@@ -45815,7 +47725,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) {
my ($db, $switch) = @$testspec;
my ($command, $deps);
- $deps = "subdirs-test_$linktype";
+ # if testdb, build all but don't test all
+ $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype";
if ($linktype eq 'static' and $self->needs_linking) {
my $target = File::Spec->rel2abs('$(MAP_TARGET)');
$command = qq{"$target" \$(MAP_PERLINC)};
@@ -45824,10 +47735,14 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$command = '$(FULLPERLRUN)' . $switch;
}
push @m, "test${db}_$linktype :: $deps\n";
- push @m, $self->test_via_harness($command, '$(TEST_FILES)')
- if $tests;
- push @m, $self->test_via_script($command, '$(TEST_FILE)')
- if -f "test.pl";
+ if ($db eq 'db') {
+ push @m, $self->test_via_script($command, '$(TEST_FILE)')
+ } else {
+ push @m, $self->test_via_script($command, '$(TEST_FILE)')
+ if -f "test.pl";
+ push @m, $self->test_via_harness($command, '$(TEST_FILES)')
+ if $tests;
+ }
push @m, "\n";
}
} else {
@@ -45884,22 +47799,23 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $foundxsubpp = 0;
foreach my $dir (@xsubpp_dirs) {
- $xsdir = File::Spec->catdir($dir, 'ExtUtils');
- if( -r File::Spec->catfile($xsdir, "xsubpp") ) {
+ $xsdir = $self->catdir($dir, 'ExtUtils');
+ if( -r $self->catfile($xsdir, "xsubpp") ) {
$foundxsubpp = 1;
last;
}
}
die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp;
- my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils");
- my(@tmdeps) = File::Spec->catfile($tmdir,'typemap');
+ my $tmdir = $self->catdir($self->{PERL_LIB},"ExtUtils");
+ my(@tmdeps) = $self->catfile($tmdir,'typemap');
if( $self->{TYPEMAPS} ){
foreach my $typemap (@{$self->{TYPEMAPS}}){
if( ! -f $typemap ) {
warn "Typemap $typemap not found.\n";
}
else {
+ $typemap = vmsify($typemap) if $Is{VMS};
push(@tmdeps, $typemap);
}
}
@@ -46008,7 +47924,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub writedoc {
# --- perllocal.pod section ---
my($self,$what,$name,@attribs)=@_;
- my $time = localtime;
+ my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time);
print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
print join "\n\n=item *\n\n", map("C<$_>",@attribs);
print "\n\n=back\n\n";
@@ -46058,10 +47974,10 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub xs_o {
my ($self) = @_;
return '' unless $self->needs_linking();
- my $minus_o = $self->xs_obj_opt('$*$(OBJ_EXT)');
+ my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
my $frag = '';
# dmake makes noise about ambiguous rule
- $frag .= sprintf <<'EOF', $minus_o unless $self->is_make_type('dmake');
+ $frag .= sprintf <<'EOF', $m_o unless $self->is_make_type('dmake');
.xs$(OBJ_EXT) :
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
$(MV) $*.xsc $*.c
@@ -46079,8 +47995,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC');
my $define = '$(DEFINE)';
$self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE');
- # 1 2 3 4
- $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $minus_o, $define;
+ # 1 2 3 4
+ $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define;
%1$s$(OBJ_EXT): %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc
@@ -46140,7 +48056,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use File::Basename;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Any;
@@ -46428,15 +48344,22 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=item pasthru (override)
- VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
- options. This is used in every invocation of make in the VMS Makefile so
- PASTHRU should not be necessary. Using PASTHRU tends to blow commands past
- the 256 character limit.
+ The list of macro definitions to be passed through must be specified using
+ the /MACRO qualifier and must not add another /DEFINE qualifier. We prepend
+ our own comma here to the contents of $(PASTHRU_DEFINE) because it is often
+ empty and a comma always present in CCFLAGS would generate a missing
+ qualifier value error.
=cut
sub pasthru {
- return "PASTHRU=\n";
+ my($self) = shift;
+ my $pasthru = $self->SUPER::pasthru;
+ $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|;
+ $pasthru =~ s|\n\z|)\n|m;
+ $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig;
+
+ return $pasthru;
}
@@ -46851,13 +48774,14 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $term = $1;
$term =~ s:^\((.+)\)$:$1:;
push @terms, $term;
- }
+ }
if ($type eq 'Def') {
push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
}
if (@terms) {
$quals =~ s:/${type}i?n?e?=[^/]+::ig;
- $quals .= "/${type}ine=(" . join(',',@terms) . ')';
+ # PASTHRU_DEFINE will have its own comma
+ $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')';
}
}
@@ -47055,24 +48979,103 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
my $version = $self->parse_version("$ext.pm");
- my $cccmd = $self->{CONST_CCCMD};
- $cccmd =~ m/^\s*CCCMD\s*=\s*(.*)\n/m;
- $cccmd = $1;
- $cccmd =~ s/\b(VERSION=)[^,\)]*/$1\\"$version\\"/;
- $cccmd =~ s/\b(XS_VERSION=)[^,\)]*/$1\\"$version\\"/;
- # 1 2
- $frag .= _sprintf562 <<'EOF', $ext, $cccmd;
+ my $ccflags = $self->{CCFLAGS};
+ $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/;
+ $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/;
+ $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC');
+ $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE');
+
+ $frag .= _sprintf562 <<'EOF', $ext, $ccflags;
%1$s$(OBJ_EXT) : %1$s.xs
$(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc
$(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c
- %2$s $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
+ $(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT)
EOF
}
}
$frag;
}
+ =item _xsbuild_replace_macro (override)
+
+ There is no simple replacement possible since a qualifier and all its
+ subqualifiers must be considered together, so we use our own utility
+ routine for the replacement.
+
+ =cut
+
+ sub _xsbuild_replace_macro {
+ my ($self, undef, $xstype, $ext, $varname) = @_;
+ my $value = $self->_xsbuild_value($xstype, $ext, $varname);
+ return unless defined $value;
+ $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname);
+ }
+
+ =item _xsbuild_value (override)
+
+ Convert the extension spec to Unix format, as that's what will
+ match what's in the XSBUILD data structure.
+
+ =cut
+
+ sub _xsbuild_value {
+ my ($self, $xstype, $ext, $varname) = @_;
+ $ext = unixify($ext);
+ return $self->SUPER::_xsbuild_value($xstype, $ext, $varname);
+ }
+
+ sub _vms_replace_qualifier {
+ my ($self, $flags, $newflag, $macro) = @_;
+ my $qual_type;
+ my $type_suffix;
+ my $quote_subquals = 0;
+ my @subquals_new = split /\s+/, $newflag;
+
+ if ($macro eq 'DEFINE') {
+ $qual_type = 'Def';
+ $type_suffix = 'ine';
+ map { $_ =~ s/^-D// } @subquals_new;
+ $quote_subquals = 1;
+ }
+ elsif ($macro eq 'INC') {
+ $qual_type = 'Inc';
+ $type_suffix = 'lude';
+ map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new;
+ }
+
+ my @subquals = ();
+ while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) {
+ my $term = $1;
+ $term =~ s/\"//g;
+ $term =~ s:^\((.+)\)$:$1:;
+ push @subquals, split /,/, $term;
+ }
+ for my $new (@subquals_new) {
+ my ($sq_new, $sqval_new) = split /=/, $new;
+ my $replaced_old = 0;
+ for my $old (@subquals) {
+ my ($sq, $sqval) = split /=/, $old;
+ if ($sq_new eq $sq) {
+ $old = $sq_new;
+ $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new);
+ $replaced_old = 1;
+ last;
+ }
+ }
+ push @subquals, $new unless $replaced_old;
+ }
+
+ if (@subquals) {
+ $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig;
+ # add quotes if requested but not for unexpanded macros
+ map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals;
+ $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')';
+ }
+
+ return $flags;
+ }
+
sub xs_dlsyms_ext {
'.opt';
@@ -47081,7 +49084,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=item dlsyms (override)
Create VMS linker options files specifying universal symbols for this
- extension's shareable image, and listing other shareable images or
+ extension's shareable image(s), and listing other shareable images or
libraries to which it should be linked.
=cut
@@ -47095,25 +49098,27 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub xs_make_dlsyms {
my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_;
my @m;
+ my $instloc;
if ($self->{XSMULTI}) {
my ($v, $d, $f) = File::Spec->splitpath($target);
my @d = File::Spec->splitdir($d);
shift @d if $d[0] eq 'lib';
- my $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f);
+ $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f);
push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'dynamic'};
push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'static'};
- push @m, sprintf <<'EOF', $instloc, $target;
+ push @m, "\n", sprintf <<'EOF', $instloc, $target;
%s : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
- } else {
+ }
+ else {
push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'dynamic'};
push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n"
unless $self->{SKIPHASH}{'static'};
- push @m, sprintf <<'EOF', $target;
+ push @m, "\n", sprintf <<'EOF', $target;
$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s
$(CP) $(MMS$SOURCE) $(MMS$TARGET)
EOF
@@ -47128,33 +49133,45 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
q!, 'DL_VARS' => !, neatvalue($vars);
push @m, $extra if defined $extra;
push @m, qq!);"\n\t!;
- push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
+ # Can't use dlbase as it's been through mod2fname.
+ my $olb_base = basename($target, '.opt');
if ($self->{XSMULTI}) {
- push @m, uc($dlbase); # the "DLBASE" - is this right?
- } elsif ($self->{OBJECT} =~ /\bBASEEXT\b/ or
- $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
- push @m, ($Config{d_vms_case_sensitive_symbols}
- ? uc($self->{BASEEXT}) :'$(BASEEXT)');
- } else { # We don't have a "main" object file, so pull 'em all in
- # Upcase module names if linker is being case-sensitive
- my($upcase) = $Config{d_vms_case_sensitive_symbols};
- my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
- for (@omods) {
- s/\.[^.]*$//; # Trim off file type
- s[\$\(\w+_EXT\)][]; # even as a macro
- s/.*[:>\/\]]//; # Trim off dir spec
- $_ = uc if $upcase;
- };
- my(@lines);
- my $tmp = shift @omods;
- foreach my $elt (@omods) {
- $tmp .= ",$elt";
- if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
+ # We've been passed everything but the kitchen sink -- and the location of the
+ # static library we're using to build the dynamic library -- so concoct that
+ # location from what we do have.
+ my $olb_dir = $self->catdir(dirname($instloc), $olb_base);
+ push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!;
+ push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base);
+ push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
+ }
+ else {
+ push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!;
+ if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
+ $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
+ push @m, ($Config{d_vms_case_sensitive_symbols}
+ ? uc($self->{BASEEXT}) :'$(BASEEXT)');
+ }
+ else { # We don't have a "main" object file, so pull 'em all in
+ # Upcase module names if linker is being case-sensitive
+ my($upcase) = $Config{d_vms_case_sensitive_symbols};
+ my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
+ for (@omods) {
+ s/\.[^.]*$//; # Trim off file type
+ s[\$\(\w+_EXT\)][]; # even as a macro
+ s/.*[:>\/\]]//; # Trim off dir spec
+ $_ = uc if $upcase;
+ };
+ my(@lines);
+ my $tmp = shift @omods;
+ foreach my $elt (@omods) {
+ $tmp .= ",$elt";
+ if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
+ }
+ push @lines, $tmp;
+ push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
}
- push @lines, $tmp;
- push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
+ push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n";
}
- push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
if (length $self->{LDLOADLIBS}) {
my($line) = '';
foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
@@ -47212,29 +49229,34 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
EOF
}
-
- =item static_lib (override)
+ =item xs_make_static_lib (override)
Use VMS commands to manipulate object library.
=cut
- sub static_lib {
- my($self) = @_;
- return '' unless $self->needs_linking();
+ sub xs_make_static_lib {
+ my ($self, $object, $to, $todir) = @_;
- return '
- $(INST_STATIC) :
- $(NOECHO) $(NOOP)
- ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
+ my @objects;
+ if ($self->{XSMULTI}) {
+ # The extension name should be the main object file name minus file type.
+ my $lib = $object;
+ $lib =~ s/\$\(OBJ_EXT\)\z//;
+ my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT');
+ $object = $override if defined $override;
+ @objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object;
+ }
+ else {
+ push @objects, $object;
+ }
- my(@m);
- push @m,'
- # Rely on suffix rule for update action
- $(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
+ my @m;
+ for my $obj (@objects) {
+ push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir);
+ }
+ push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects));
- $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
- ';
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
@@ -47245,8 +49267,11 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# 'cause it's a library and you can't stick them in other libraries.
# In that case, we use $OBJECT instead and hope for the best
if ($self->{MYEXTLIB}) {
- push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
- } else {
+ for my $obj (@objects) {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n");
+ }
+ }
+ else {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
@@ -47528,7 +49553,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
]);
}
- push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
+ push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
if %{$self->{XS}};
join('',@m);
@@ -47638,7 +49663,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# (e.g. Intuit::DWIM will precede Intuit, so unresolved
# references from [.intuit.dwim]dwim.obj can be found
# in [.intuit]intuit.olb).
- for (sort { length($a) <=> length($b) } keys %olbs) {
+ for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) {
next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
my($dir) = $self->fixpath($_,1);
my($extralibs) = $dir . "extralibs.ld";
@@ -47933,7 +49958,8 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
- $cmd = $self->quote_literal($cmd);
+ my @cmds = split /\n/, $cmd;
+ $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
$cmd = $self->escape_newlines($cmd);
# Switches must be quoted else they will be lowercased.
@@ -48143,7 +50169,12 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$complex = 1;
}
}
- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
+ else {
+ $macro = $self->{$macro};
+ # Don't unixify if there is unescaped whitespace
+ $macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/);
+ $macro =~ s#/\Z(?!\n)##;
+ }
$npath = "$head$macro$tail";
}
}
@@ -48271,7 +50302,7 @@ $fatpacked{"ExtUtils/MM_VOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_VOS;
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Unix;
@@ -48351,12 +50382,12 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
$ENV{EMXSHELL} = 'sh'; # to run `commands`
- my ( $BORLAND, $GCC, $MSVC, $DLLTOOL ) = _identify_compiler_environment( \%Config );
+ my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config );
sub _identify_compiler_environment {
my ( $config ) = @_;
@@ -48364,9 +50395,8 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0;
my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C
- my $DLLTOOL = $config->{dlltool} || 'dlltool';
- return ( $BORLAND, $GCC, $MSVC, $DLLTOOL );
+ return ( $BORLAND, $GCC, $MSVC );
}
@@ -48976,7 +51006,7 @@ $fatpacked{"ExtUtils/MM_Win95.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require ExtUtils::MM_Win32;
@@ -49056,7 +51086,7 @@ $fatpacked{"ExtUtils/MY.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXT
use strict;
require ExtUtils::MM;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
our @ISA = qw(ExtUtils::MM);
@@ -49109,7 +51139,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
use File::Path;
my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone
eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') }
- if $CAN_DECODE and $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE eq 'US-ASCII';
+ if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii';
our $Verbose = 0; # exported
our @Parent; # needs to be localized
@@ -49121,7 +51151,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
# Emulate something resembling CVS $Revision$
@@ -49131,7 +51161,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
our $Filename = __FILE__; # referenced outside MakeMaker
our @ISA = qw(Exporter);
- our @EXPORT = qw(&WriteMakefile $Verbose &prompt);
+ our @EXPORT = qw(&WriteMakefile $Verbose &prompt &os_unsupported);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
&WriteEmptyMakefile &open_for_writing &write_file_via_tmp
&_sprintf562);
@@ -49140,7 +51170,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
# purged.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
- my $UNDER_CORE = $ENV{PERL_CORE};
+ our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our
full_setup();
@@ -49249,7 +51279,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
sub _verify_att {
my($att) = @_;
- while( my($key, $val) = each %$att ) {
+ foreach my $key (sort keys %$att) {
+ my $val = $att->{$key};
my $sig = $Att_Sigs{$key};
unless( defined $sig ) {
warn "WARNING: $key is not a known parameter.\n";
@@ -49323,6 +51354,10 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
return (!defined $ans || $ans eq '') ? $def : $ans;
}
+ sub os_unsupported {
+ die "OS unsupported\n";
+ }
+
sub eval_in_subdirs {
my($self) = @_;
use Cwd qw(cwd abs_path);
@@ -49547,8 +51582,16 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
$self->{$key},
{
bad_version_hook => sub {
- carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as 0";
- version->new(0);
+ #no warnings 'numeric'; # module doesn't use warnings
+ my $fallback;
+ if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf "%f", $_[0];
+ } else {
+ ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback";
+ }
+ version->new($fallback);
},
},
);
@@ -49557,13 +51600,23 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
} else {
for my $module (sort keys %{ $self->{$key} }) {
my $version = $self->{$key}->{$module};
+ my $fallback = 0;
if (!defined($version) or !length($version)) {
carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)";
- } else {
- next if $version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/;
- carp "Unparsable version '$version' for prerequisite $module treated as 0 (CPAN::Meta::Requirements not available)";
}
- $self->{$key}->{$module} = 0;
+ elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) {
+ next;
+ }
+ else {
+ if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf "%f", $version;
+ } else {
+ ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)";
+ }
+ }
+ $self->{$key}->{$module} = $fallback;
}
}
}
@@ -49578,7 +51631,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
}
print "MakeMaker (v$VERSION)\n" if $Verbose;
- if (-f "MANIFEST" && ! -f "Makefile" && ! $ENV{PERL_CORE}){
+ if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){
check_manifest();
}
@@ -49670,6 +51723,18 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
$installed_file = MM->_installed_file_for_module($prereq);
$pr_version = MM->parse_version($installed_file) if $installed_file;
$pr_version = 0 if $pr_version eq 'undef';
+ if ( !eval { version->new( $pr_version ); 1 } ) {
+ #no warnings 'numeric'; # module doesn't use warnings
+ my $fallback;
+ if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) {
+ $fallback = sprintf '%f', $pr_version;
+ } else {
+ ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0;
+ $fallback += 0;
+ carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback";
+ }
+ $pr_version = $fallback;
+ }
}
# convert X.Y_Z alpha version #s to X.YZ for easier comparisons
@@ -49679,7 +51744,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
warn sprintf "Warning: prerequisite %s %s not found.\n",
$prereq, $required_version
unless $self->{PREREQ_FATAL}
- or $ENV{PERL_CORE};
+ or $UNDER_CORE;
$unsatisfied{$prereq} = 'not installed';
}
@@ -49691,7 +51756,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n",
$prereq, $required_version, ($pr_version || 'unknown version')
unless $self->{PREREQ_FATAL}
- or $ENV{PERL_CORE};
+ or $UNDER_CORE;
$unsatisfied{$prereq} = $required_version || 'unknown version' ;
}
@@ -49718,11 +51783,6 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
}
}
- # This is for old Makefiles written pre 5.00, will go away
- if ( Carp::longmess("") =~ /runsubdirpl/s ){
- carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
- }
-
my $newclass = ++$PACKNAME;
local @Parent = @Parent; # Protect against non-local exits
{
@@ -49917,12 +51977,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2;
my %att = @_;
- $att{NAME} = 'Dummy' unless $att{NAME}; # eliminate pointless warnings
$att{DIR} = [] unless $att{DIR}; # don't recurse by default
my $self = MM->new(\%att);
- require File::Path;
- require File::Spec;
- File::Path::rmtree( File::Spec->catdir(qw[blib _eumm]) ); # because MM->new does too much stuff
my $new = $self->{MAKEFILE};
my $old = $self->{MAKEFILE_OLD};
@@ -49933,7 +51989,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
_rename($new, $old) or warn "rename $new => $old: $!"
}
open my $mfh, '>', $new or die "open $new for write: $!";
- printf $mfh <<'EOP', $self->{RM_F}, $self->{MAKEFILE};
+ print $mfh <<'EOP';
all :
manifypods :
@@ -49944,10 +52000,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
static :
- realclean : clean
-
clean :
- %s %s
install :
@@ -50272,6 +52325,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
sub skipcheck {
my($self) = shift;
my($section) = @_;
+ return 'skipped' if $section eq 'metafile' && $UNDER_CORE;
if ($section eq 'dynamic') {
print "Warning (non-fatal): Target 'dynamic' depends on targets ",
"in skipped section 'dynamic_bs'\n"
@@ -50308,8 +52362,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
my $self = shift;
my $finalname = $self->{MAKEFILE};
- printf "Generating a %s %s\n", $self->make_type, $finalname;
- print "Writing $finalname for $self->{NAME}\n";
+ printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT};
+ print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT};
unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
@@ -50444,14 +52498,10 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
# here so even if top_targets is overridden, these will still be defined
# gmake will silently still work if any are .PHONY-ed but nmake won't
- static ::
- $(NOECHO) $(NOOP)
-
- dynamic ::
- $(NOECHO) $(NOOP)
EOF
push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n",
# config is so manifypods won't puke if no subdirs
+ grep !$self->{SKIPHASH}{$_},
qw(static dynamic config);
join "\n", @m;
}
@@ -50542,6 +52592,23 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
execute all matching files in alphabetical order via the
L<Test::Harness> module with the C<-I> switches set correctly.
+ You can also organize your tests within subdirectories in the F<t/> directory.
+ To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you
+ had tests in:
+
+ t/foo
+ t/foo/bar
+
+ You could tell make to run tests in both of those directories with the
+ following directives:
+
+ test => {TESTS => 't/*/*.t t/*/*/*.t'}
+ test => {TESTS => 't/foo/*.t t/foo/bar/*.t'}
+
+ The first will run all test files in all first-level subdirectories and all
+ subdirectories they contain. The second will run tests in only the F<t/foo>
+ and F<t/foo/bar>.
+
If you'd like to see the raw output of your tests, set the
C<TEST_VERBOSE> variable to true.
@@ -52073,6 +54140,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
{RECURSIVE_TEST_FILES=>1}
+ This is supported since 6.76
+
=item tool_autosplit
{MAXLEN => 8}
@@ -52301,13 +54370,13 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
seamlessly and rapidly populate CPAN with module meta-data. If you wish to
shut this feature off, set the C<NO_META> C<WriteMakefile()> flag to true.
- At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agrees
+ At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agreed
to use the CPAN Meta format to communicate post-configuration requirements
between toolchain components. These files, F<MYMETA.json> and F<MYMETA.yml>,
are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta>
- is installed). Clients like L<CPAN> or L<CPANPLUS> will read this
+ is installed). Clients like L<CPAN> or L<CPANPLUS> will read these
files to see what prerequisites must be fulfilled before building or testing
- the distribution. If you with to shut this feature off, set the C<NO_MYMETA>
+ the distribution. If you wish to shut this feature off, set the C<NO_MYMETA>
C<WriteMakeFile()> flag to true.
=head2 Disabling an extension
@@ -52349,6 +54418,17 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
If no $default is provided an empty string will be used instead.
+ =item os_unsupported
+
+ os_unsupported();
+ os_unsupported if $^O eq 'MSWin32';
+
+ The C<os_unsupported()> function provides a way to correctly exit your
+ C<Makefile.PL> before calling C<WriteMakefile>. It is essentially a
+ C<die> with the message "OS unsupported".
+
+ This is supported since 7.26
+
=back
=head2 Supported versions of Perl
@@ -52436,7 +54516,7 @@ $fatpacked{"ExtUtils/MakeMaker/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
use strict;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
use Config ();
@@ -52478,7 +54558,7 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
package ExtUtils::MakeMaker::Locale;
use strict;
- our $VERSION = "7.06";
+ our $VERSION = "7.30";
$VERSION = eval $VERSION;
use base 'Exporter';
@@ -52505,11 +54585,8 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
eval {
unless (defined &GetConsoleCP) {
require Win32;
- # no point falling back to Win32::GetConsoleCP from this
- # as added same time, 0.45
- eval { Win32::GetConsoleCP() };
# manually "import" it since Win32->import refuses
- *GetConsoleCP = sub { &Win32::GetConsoleCP } unless $@;
+ *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
}
unless (defined &GetConsoleCP) {
require Win32::API;
@@ -52529,18 +54606,17 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
require Win32;
eval { Win32::GetConsoleCP() };
# manually "import" it since Win32->import refuses
- *GetInputCP = sub { &Win32::GetConsoleCP } unless $@;
- *GetOutputCP = sub { &Win32::GetConsoleOutputCP } unless $@;
+ *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
+ *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP;
};
unless (defined &GetInputCP) {
eval {
# try Win32::Console module for codepage to use
require Win32::Console;
- eval { Win32::Console::InputCP() };
*GetInputCP = sub { &Win32::Console::InputCP }
- unless $@;
+ if defined &Win32::Console::InputCP;
*GetOutputCP = sub { &Win32::Console::OutputCP }
- unless $@;
+ if defined &Win32::Console::OutputCP;
};
}
unless (defined &GetInputCP) {
@@ -52615,7 +54691,7 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
sub _flush_aliases {
no strict 'refs';
- for my $a (keys %Encode::Alias::Alias) {
+ for my $a (sort keys %Encode::Alias::Alias) {
if (defined ${"ENCODING_" . uc($a)}) {
delete $Encode::Alias::Alias{$a};
warn "Flushed alias cache for $a" if DEBUG;
@@ -52872,7 +54948,7 @@ $fatpacked{"ExtUtils/MakeMaker/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE_
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
- $VERSION = '7.06';
+ $VERSION = '7.30';
$VERSION = eval $VERSION;
$CLASS = 'version';
@@ -52926,7 +55002,7 @@ $fatpacked{"ExtUtils/MakeMaker/version/regex.pm"} = '#line '.(1+__LINE__).' "'._
use vars qw($VERSION $CLASS $STRICT $LAX);
- $VERSION = '7.06';
+ $VERSION = '7.30';
$VERSION = eval $VERSION;
#--------------------------------------------------------------------------#
@@ -53171,7 +55247,7 @@ $fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__F
use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
- $VERSION = '7.06';
+ $VERSION = '7.30';
$VERSION = eval $VERSION;
$CLASS = 'ExtUtils::MakeMaker::version::vpp';
@@ -54992,7 +57068,7 @@ $fatpacked{"ExtUtils/Mkbootstrap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
require Exporter;
@@ -55114,7 +57190,7 @@ $fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
sub Mksymlists {
@@ -55422,13 +57498,369 @@ $fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
Last revised 14-Feb-1996, for Perl 5.002.
EXTUTILS_MKSYMLISTS
+$fatpacked{"ExtUtils/Packlist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_PACKLIST';
+ package ExtUtils::Packlist;
+
+ use 5.00503;
+ use strict;
+ use Carp qw();
+ use Config;
+ use vars qw($VERSION $Relocations);
+ $VERSION = '2.06';
+ $VERSION = eval $VERSION;
+
+ # Used for generating filehandle globs. IO::File might not be available!
+ my $fhname = "FH1";
+
+ =begin _undocumented
+
+ =over
+
+ =item mkfh()
+
+ Make a filehandle. Same kind of idea as Symbol::gensym().
+
+ =cut
+
+ sub mkfh()
+ {
+ no strict;
+ local $^W;
+ my $fh = \*{$fhname++};
+ use strict;
+ return($fh);
+ }
+
+ =item __find_relocations
+
+ Works out what absolute paths in the configuration have been located at run
+ time relative to $^X, and generates a regexp that matches them
+
+ =back
+
+ =end _undocumented
+
+ =cut
+
+ sub __find_relocations
+ {
+ my %paths;
+ while (my ($raw_key, $raw_val) = each %Config) {
+ my $exp_key = $raw_key . "exp";
+ next unless exists $Config{$exp_key};
+ next unless $raw_val =~ m!\.\.\./!;
+ $paths{$Config{$exp_key}}++;
+ }
+ # Longest prefixes go first in the alternatives
+ my $alternations = join "|", map {quotemeta $_}
+ sort {length $b <=> length $a} keys %paths;
+ qr/^($alternations)/o;
+ }
+
+ sub new($$)
+ {
+ my ($class, $packfile) = @_;
+ $class = ref($class) || $class;
+ my %self;
+ tie(%self, $class, $packfile);
+ return(bless(\%self, $class));
+ }
+
+ sub TIEHASH
+ {
+ my ($class, $packfile) = @_;
+ my $self = { packfile => $packfile };
+ bless($self, $class);
+ $self->read($packfile) if (defined($packfile) && -f $packfile);
+ return($self);
+ }
+
+ sub STORE
+ {
+ $_[0]->{data}->{$_[1]} = $_[2];
+ }
+
+ sub FETCH
+ {
+ return($_[0]->{data}->{$_[1]});
+ }
+
+ sub FIRSTKEY
+ {
+ my $reset = scalar(keys(%{$_[0]->{data}}));
+ return(each(%{$_[0]->{data}}));
+ }
+
+ sub NEXTKEY
+ {
+ return(each(%{$_[0]->{data}}));
+ }
+
+ sub EXISTS
+ {
+ return(exists($_[0]->{data}->{$_[1]}));
+ }
+
+ sub DELETE
+ {
+ return(delete($_[0]->{data}->{$_[1]}));
+ }
+
+ sub CLEAR
+ {
+ %{$_[0]->{data}} = ();
+ }
+
+ sub DESTROY
+ {
+ }
+
+ sub read($;$)
+ {
+ my ($self, $packfile) = @_;
+ $self = tied(%$self) || $self;
+
+ if (defined($packfile)) { $self->{packfile} = $packfile; }
+ else { $packfile = $self->{packfile}; }
+ Carp::croak("No packlist filename specified") if (! defined($packfile));
+ my $fh = mkfh();
+ open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
+ $self->{data} = {};
+ my ($line);
+ while (defined($line = <$fh>))
+ {
+ chomp $line;
+ my ($key, $data) = $line;
+ if ($key =~ /^(.*?)( \w+=.*)$/)
+ {
+ $key = $1;
+ $data = { map { split('=', $_) } split(' ', $2)};
+
+ if ($Config{userelocatableinc} && $data->{relocate_as})
+ {
+ require File::Spec;
+ require Cwd;
+ my ($vol, $dir) = File::Spec->splitpath($packfile);
+ my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
+ $key = Cwd::realpath($newpath);
+ }
+ }
+ $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
+ $self->{data}->{$key} = $data;
+ }
+ close($fh);
+ }
+
+ sub write($;$)
+ {
+ my ($self, $packfile) = @_;
+ $self = tied(%$self) || $self;
+ if (defined($packfile)) { $self->{packfile} = $packfile; }
+ else { $packfile = $self->{packfile}; }
+ Carp::croak("No packlist filename specified") if (! defined($packfile));
+ my $fh = mkfh();
+ open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
+ foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ my $data = $self->{data}->{$key};
+ if ($Config{userelocatableinc}) {
+ $Relocations ||= __find_relocations();
+ if ($packfile =~ $Relocations) {
+ # We are writing into a subdirectory of a run-time relocated
+ # path. Figure out if the this file is also within a subdir.
+ my $prefix = $1;
+ if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
+ {
+ # The relocated path is within the found prefix
+ my $packfile_prefix;
+ (undef, $packfile_prefix)
+ = File::Spec->splitpath($packfile);
+
+ my $relocate_as
+ = File::Spec->abs2rel($key, $packfile_prefix);
+
+ if (!ref $data) {
+ $data = {};
+ }
+ $data->{relocate_as} = $relocate_as;
+ }
+ }
+ }
+ print $fh ("$key");
+ if (ref($data))
+ {
+ foreach my $k (sort(keys(%$data)))
+ {
+ print $fh (" $k=$data->{$k}");
+ }
+ }
+ print $fh ("\n");
+ }
+ close($fh);
+ }
+
+ sub validate($;$)
+ {
+ my ($self, $remove) = @_;
+ $self = tied(%$self) || $self;
+ my @missing;
+ foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ if (! -e $key)
+ {
+ push(@missing, $key);
+ delete($self->{data}{$key}) if ($remove);
+ }
+ }
+ return(@missing);
+ }
+
+ sub packlist_file($)
+ {
+ my ($self) = @_;
+ $self = tied(%$self) || $self;
+ return($self->{packfile});
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ ExtUtils::Packlist - manage .packlist files
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::Packlist;
+ my ($pl) = ExtUtils::Packlist->new('.packlist');
+ $pl->read('/an/old/.packlist');
+ my @missing_files = $pl->validate();
+ $pl->write('/a/new/.packlist');
+
+ $pl->{'/some/file/name'}++;
+ or
+ $pl->{'/some/other/file/name'} = { type => 'file',
+ from => '/some/file' };
+
+ =head1 DESCRIPTION
+
+ ExtUtils::Packlist provides a standard way to manage .packlist files.
+ Functions are provided to read and write .packlist files. The original
+ .packlist format is a simple list of absolute pathnames, one per line. In
+ addition, this package supports an extended format, where as well as a filename
+ each line may contain a list of attributes in the form of a space separated
+ list of key=value pairs. This is used by the installperl script to
+ differentiate between files and links, for example.
+
+ =head1 USAGE
+
+ The hash reference returned by the new() function can be used to examine and
+ modify the contents of the .packlist. Items may be added/deleted from the
+ .packlist by modifying the hash. If the value associated with a hash key is a
+ scalar, the entry written to the .packlist by any subsequent write() will be a
+ simple filename. If the value is a hash, the entry written will be the
+ filename followed by the key=value pairs from the hash. Reading back the
+ .packlist will recreate the original entries.
+
+ =head1 FUNCTIONS
+
+ =over 4
+
+ =item new()
+
+ This takes an optional parameter, the name of a .packlist. If the file exists,
+ it will be opened and the contents of the file will be read. The new() method
+ returns a reference to a hash. This hash holds an entry for each line in the
+ .packlist. In the case of old-style .packlists, the value associated with each
+ key is undef. In the case of new-style .packlists, the value associated with
+ each key is a hash containing the key=value pairs following the filename in the
+ .packlist.
+
+ =item read()
+
+ This takes an optional parameter, the name of the .packlist to be read. If
+ no file is specified, the .packlist specified to new() will be read. If the
+ .packlist does not exist, Carp::croak will be called.
+
+ =item write()
+
+ This takes an optional parameter, the name of the .packlist to be written. If
+ no file is specified, the .packlist specified to new() will be overwritten.
+
+ =item validate()
+
+ This checks that every file listed in the .packlist actually exists. If an
+ argument which evaluates to true is given, any missing files will be removed
+ from the internal hash. The return value is a list of the missing files, which
+ will be empty if they all exist.
+
+ =item packlist_file()
+
+ This returns the name of the associated .packlist file
+
+ =back
+
+ =head1 EXAMPLE
+
+ Here's C<modrm>, a little utility to cleanly remove an installed module.
+
+ #!/usr/local/bin/perl -w
+
+ use strict;
+ use IO::Dir;
+ use ExtUtils::Packlist;
+ use ExtUtils::Installed;
+
+ sub emptydir($) {
+ my ($dir) = @_;
+ my $dh = IO::Dir->new($dir) || return(0);
+ my @count = $dh->read();
+ $dh->close();
+ return(@count == 2 ? 1 : 0);
+ }
+
+ # Find all the installed packages
+ print("Finding all installed modules...\n");
+ my $installed = ExtUtils::Installed->new();
+
+ foreach my $module (grep(!/^Perl$/, $installed->modules())) {
+ my $version = $installed->version($module) || "???";
+ print("Found module $module Version $version\n");
+ print("Do you want to delete $module? [n] ");
+ my $r = <STDIN>; chomp($r);
+ if ($r && $r =~ /^y/i) {
+ # Remove all the files
+ foreach my $file (sort($installed->files($module))) {
+ print("rm $file\n");
+ unlink($file);
+ }
+ my $pf = $installed->packlist($module)->packlist_file();
+ print("rm $pf\n");
+ unlink($pf);
+ foreach my $dir (sort($installed->directory_tree($module))) {
+ if (emptydir($dir)) {
+ print("rmdir $dir\n");
+ rmdir($dir);
+ }
+ }
+ }
+ }
+
+ =head1 AUTHOR
+
+ Alan Burlison <Alan.Burlison@uk.sun.com>
+
+ =cut
+EXTUTILS_PACKLIST
+
$fatpacked{"ExtUtils/testlib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TESTLIB';
package ExtUtils::testlib;
use strict;
use warnings;
- our $VERSION = '7.06';
+ our $VERSION = '7.30';
$VERSION = eval $VERSION;
use Cwd;
@@ -55474,23 +57906,24 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
- # Last Modified On: Tue Jun 16 15:28:03 2015
- # Update Count : 1695
+ # Last Modified On: Sat May 27 12:11:39 2017
+ # Update Count : 1715
# Status : Released
################ Module Preamble ################
- package Getopt::Long;
-
use 5.004;
use strict;
+ use warnings;
+
+ package Getopt::Long;
use vars qw($VERSION);
- $VERSION = 2.47;
+ $VERSION = 2.50;
# For testing versions only.
use vars qw($VERSION_STRING);
- $VERSION_STRING = "2.47";
+ $VERSION_STRING = "2.50";
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@@ -56515,7 +58948,8 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
# Complete the option name, if appropriate.
if ( @hits == 1 && $hits[0] ne $opt ) {
$tryopt = $hits[0];
- $tryopt = lc ($tryopt) if $ignorecase;
+ $tryopt = lc ($tryopt)
+ if $ignorecase > (($bundling && length($tryopt) == 1) ? 1 : 0);
print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
if $debug;
}
@@ -56579,9 +59013,26 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
my $mand = $ctl->[CTL_AMIN];
# Check if there is an option argument available.
- if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
- return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
- $optarg = 0 unless $type eq 's';
+ if ( $gnu_compat ) {
+ my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux
+ if ( defined($optarg) ) {
+ $optargtype = (length($optarg) == 0) ? 1 : 2;
+ }
+ elsif ( defined $rest || @$argv > 0 ) {
+ # GNU getopt_long() does not accept the (optional)
+ # argument to be passed to the option without = sign.
+ # We do, since not doing so breaks existing scripts.
+ $optargtype = 3;
+ }
+ if(($optargtype == 0) && !$mand) {
+ my $val
+ = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT]
+ : $type eq 's' ? ''
+ : 0;
+ return (1, $opt, $ctl, $val);
+ }
+ return (1, $opt, $ctl, $type eq 's' ? '' : 0)
+ if $optargtype == 1; # --foo= -> return nothing
}
# Check if there is an option argument available.
@@ -56829,6 +59280,8 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
}
elsif ( $try eq 'gnu_compat' ) {
$gnu_compat = $action;
+ $bundling = 0;
+ $bundling_values = 1;
}
elsif ( $try =~ /^(auto_?)?version$/ ) {
$auto_version = $action;
@@ -56915,7 +59368,7 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
my $v = $main::VERSION;
my $fh = $pa->{-output} ||
- ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
+ ( ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR );
print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
$0, defined $v ? " version $v" : (),
@@ -57217,12 +59670,12 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
GetOptions ("library=s" => \@libfiles);
Alternatively, you can specify that the option can have multiple
- values by adding a "@", and pass a scalar reference as the
+ values by adding a "@", and pass a reference to a scalar as the
destination:
GetOptions ("library=s@" => \$libfiles);
- Used with the example above, C<@libfiles> (or C<@$libfiles>) would
+ Used with the example above, C<@libfiles> c.q. C<@$libfiles> would
contain two strings upon completion: C<"lib/stdlib"> and
C<"lib/extlib">, in that order. It is also possible to specify that
only integer or floating point numbers are acceptable values.
@@ -57786,11 +60239,14 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
C<--opt=> will give option C<opt> and empty value.
This is the way GNU getopt_long() does it.
+ Note that C<--opt value> is still accepted, even though GNU
+ getopt_long() doesn't.
+
=item gnu_getopt
This is a short way of setting C<gnu_compat> C<bundling> C<permute>
C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
- fully compatible with GNU getopt_long().
+ reasonably compatible with GNU getopt_long().
=item require_order
@@ -58219,21 +60675,21 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
use strict;
use Carp ();
- use base qw(Exporter);
+ use Exporter;
+ BEGIN { @JSON::ISA = 'Exporter' }
+
@JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
BEGIN {
- $JSON::VERSION = '2.90';
+ $JSON::VERSION = '2.94';
$JSON::DEBUG = 0 unless (defined $JSON::DEBUG);
$JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
}
- my $Module_XS = 'JSON::XS';
- my $Module_PP = 'JSON::PP';
- my $Module_bp = 'JSON::backportPP'; # included in JSON distribution
- my $PP_Version = '2.27203';
- my $XS_Version = '2.34';
-
+ my %RequiredVersion = (
+ 'JSON::PP' => '2.27203',
+ 'JSON::XS' => '2.34',
+ );
# XS and PP common methods
@@ -58258,10 +60714,8 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
# used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die.
- my $_INSTALL_ONLY = 2; # Don't call _set_methods()
my $_ALLOW_UNSUPPORTED = 0;
my $_UNIV_CONV_BLESSED = 0;
- my $_USSING_bpPP = 0;
# Check the environment variable to decide worker module.
@@ -58271,21 +60725,32 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
- if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
- _load_xs($_INSTALL_DONT_DIE) or _load_pp();
+ if ($backend eq '1') {
+ $backend = 'JSON::XS,JSON::PP';
}
- elsif ($backend eq '0' or $backend eq 'JSON::PP') {
- _load_pp();
+ elsif ($backend eq '0') {
+ $backend = 'JSON::PP';
}
- elsif ($backend eq '2' or $backend eq 'JSON::XS') {
- _load_xs();
+ elsif ($backend eq '2') {
+ $backend = 'JSON::XS';
}
- elsif ($backend eq 'JSON::backportPP') {
- $_USSING_bpPP = 1;
- _load_pp();
- }
- else {
- Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
+ $backend =~ s/\s+//g;
+
+ my @backend_modules = split /,/, $backend;
+ while(my $module = shift @backend_modules) {
+ if ($module =~ /JSON::XS/) {
+ _load_xs($module, @backend_modules ? $_INSTALL_DONT_DIE : 0);
+ }
+ elsif ($module =~ /JSON::PP/) {
+ _load_pp($module);
+ }
+ elsif ($module =~ /JSON::backportPP/) {
+ _load_pp($module);
+ }
+ else {
+ Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
+ }
+ last if $JSON::Backend;
}
}
@@ -58299,7 +60764,7 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
if ($tag eq '-support_by_pp') {
if (!$_ALLOW_UNSUPPORTED++) {
JSON::Backend::XS
- ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
+ ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend->is_xs);
}
next;
}
@@ -58307,15 +60772,22 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$no_export++, next;
}
elsif ( $tag eq '-convert_blessed_universally' ) {
+ my $org_encode = $JSON::Backend->can('encode');
eval q|
require B;
- *UNIVERSAL::TO_JSON = sub {
- my $b_obj = B::svref_2object( $_[0] );
- return $b_obj->isa('B::HV') ? { %{ $_[0] } }
- : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
- : undef
- ;
- }
+ local $^W;
+ no strict 'refs';
+ *{"${JSON::Backend}\::encode"} = sub {
+ # only works with Perl 5.18+
+ local *UNIVERSAL::TO_JSON = sub {
+ my $b_obj = B::svref_2object( $_[0] );
+ return $b_obj->isa('B::HV') ? { %{ $_[0] } }
+ : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
+ : undef
+ ;
+ };
+ $org_encode->(@_);
+ };
| if ( !$_UNIV_CONV_BLESSED++ );
next;
}
@@ -58396,7 +60868,7 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
sub null { undef; }
- sub require_xs_version { $XS_Version; }
+ sub require_xs_version { $RequiredVersion{'JSON::XS'}; }
sub backend {
my $proto = shift;
@@ -58407,12 +60879,12 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
sub is_xs {
- return $_[0]->backend eq $Module_XS;
+ return $_[0]->backend->is_xs;
}
sub is_pp {
- return not $_[0]->is_xs;
+ return $_[0]->backend->is_pp;
}
@@ -58457,172 +60929,106 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
# INTERNAL
- sub _load_xs {
- my $opt = shift;
-
- $JSON::DEBUG and Carp::carp "Load $Module_XS.";
+ sub __load_xs {
+ my ($module, $opt) = @_;
- # if called after install module, overload is disable.... why?
- JSON::Boolean::_overrride_overload($Module_XS);
- JSON::Boolean::_overrride_overload($Module_PP);
+ $JSON::DEBUG and Carp::carp "Load $module.";
+ my $required_version = $RequiredVersion{$module} || '';
eval qq|
- use $Module_XS $XS_Version ();
+ use $module $required_version ();
|;
if ($@) {
if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
- $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
+ $JSON::DEBUG and Carp::carp "Can't load $module...($@)";
return 0;
}
Carp::croak $@;
}
+ $JSON::BackendModuleXS = $module;
+ return 1;
+ }
- unless (defined $opt and $opt & $_INSTALL_ONLY) {
- _set_module( $JSON::Backend = $Module_XS );
- my $data = join("", <DATA>); # this code is from Jcode 2.xx.
- close(DATA);
- eval $data;
- JSON::Backend::XS->init;
- }
+ sub _load_xs {
+ my ($module, $opt) = @_;
+ __load_xs($module, $opt) or return;
+
+ my $data = join("", <DATA>); # this code is from Jcode 2.xx.
+ close(DATA);
+ eval $data;
+ JSON::Backend::XS->init($module);
return 1;
};
- sub _load_pp {
- my $opt = shift;
- my $backend = $_USSING_bpPP ? $Module_bp : $Module_PP;
+ sub __load_pp {
+ my ($module, $opt) = @_;
- $JSON::DEBUG and Carp::carp "Load $backend.";
+ $JSON::DEBUG and Carp::carp "Load $module.";
+ my $required_version = $RequiredVersion{$module} || '';
- # if called after install module, overload is disable.... why?
- JSON::Boolean::_overrride_overload($Module_XS);
- JSON::Boolean::_overrride_overload($backend);
-
- if ( $_USSING_bpPP ) {
- eval qq| require $backend |;
- }
- else {
- eval qq| use $backend $PP_Version () |;
- }
+ eval qq| use $module $required_version () |;
if ($@) {
- if ( $backend eq $Module_PP ) {
- $JSON::DEBUG and Carp::carp "Can't load $Module_PP ($@), so try to load $Module_bp";
- $_USSING_bpPP++;
- $backend = $Module_bp;
- JSON::Boolean::_overrride_overload($backend);
+ if ( $module eq 'JSON::PP' ) {
+ $JSON::DEBUG and Carp::carp "Can't load $module ($@), so try to load JSON::backportPP";
+ $module = 'JSON::backportPP';
local $^W; # if PP installed but invalid version, backportPP redefines methods.
- eval qq| require $Module_bp |;
+ eval qq| require $module |;
}
Carp::croak $@ if $@;
}
-
- unless (defined $opt and $opt & $_INSTALL_ONLY) {
- _set_module( $JSON::Backend = $Module_PP ); # even if backportPP, set $Backend with 'JSON::PP'
- JSON::Backend::PP->init;
- }
- };
-
-
- sub _set_module {
- return if defined $JSON::true;
-
- my $module = shift;
-
- local $^W;
- no strict qw(refs);
-
- $JSON::true = ${"$module\::true"};
- $JSON::false = ${"$module\::false"};
-
- push @JSON::ISA, $module;
- if ( JSON->is_xs and JSON->backend->VERSION < 3 ) {
- eval 'package JSON::PP::Boolean';
- push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
- }
-
- *{"JSON::is_bool"} = \&{"$module\::is_bool"};
-
- for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
- *{"JSON::$method"} = sub {
- Carp::carp("$method is not supported in $module.");
- $_[0];
- };
- }
-
+ $JSON::BackendModulePP = $module;
return 1;
}
+ sub _load_pp {
+ my ($module, $opt) = @_;
+ __load_pp($module, $opt);
+ JSON::Backend::PP->init($module);
+ };
#
- # JSON Boolean
+ # Helper classes for Backend Module (PP)
#
- package JSON::Boolean;
+ package JSON::Backend::PP;
- my %Installed;
+ sub init {
+ my ($class, $module) = @_;
- sub _overrride_overload {
- return; # this function is currently disable.
- return if ($Installed{ $_[0] }++);
+ # name may vary, but the module should (always) be a JSON::PP
- my $boolean = $_[0] . '::Boolean';
+ local $^W;
+ no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called.
+ *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
+ *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
+ *{"JSON::is_bool"} = \&{"JSON::PP::is_bool"};
- eval sprintf(q|
- package %s;
- use overload (
- '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
- 'eq' => sub {
- my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
- if ($op eq 'true' or $op eq 'false') {
- return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
- }
- else {
- return $obj ? 1 == $op : 0 == $op;
- }
- },
- );
- |, $boolean);
+ $JSON::true = ${"JSON::PP::true"};
+ $JSON::false = ${"JSON::PP::false"};
- if ($@) { Carp::croak $@; }
+ push @JSON::Backend::PP::ISA, 'JSON::PP';
+ push @JSON::ISA, $class;
+ $JSON::Backend = $class;
+ $JSON::BackendModule = $module;
+ ${"$class\::VERSION"} = $module->VERSION;
- if ( exists $INC{'JSON/XS.pm'} and $boolean eq 'JSON::XS::Boolean' ) {
- local $^W;
- my $true = do { bless \(my $dummy = 1), $boolean };
- my $false = do { bless \(my $dummy = 0), $boolean };
- *JSON::XS::true = sub () { $true };
- *JSON::XS::false = sub () { $false };
- }
- elsif ( exists $INC{'JSON/PP.pm'} and $boolean eq 'JSON::PP::Boolean' ) {
- local $^W;
- my $true = do { bless \(my $dummy = 1), $boolean };
- my $false = do { bless \(my $dummy = 0), $boolean };
- *JSON::PP::true = sub { $true };
- *JSON::PP::false = sub { $false };
+ for my $method (@XSOnlyMethods) {
+ *{"JSON::$method"} = sub {
+ Carp::carp("$method is not supported in $module.");
+ $_[0];
+ };
}
return 1;
}
-
- #
- # Helper classes for Backend Module (PP)
- #
-
- package JSON::Backend::PP;
-
- sub init {
- local $^W;
- no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called.
- *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
- *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
- *{"JSON::PP::is_xs"} = sub { 0 };
- *{"JSON::PP::is_pp"} = sub { 1 };
- return 1;
- }
+ sub is_xs { 0 };
+ sub is_pp { 1 };
#
# To save memory, the below lines are read only when XS backend is used.
@@ -58640,201 +61046,69 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
package JSON::Backend::XS;
- use constant INDENT_LENGTH_FLAG => 15 << 12;
-
- use constant UNSUPPORTED_ENCODE_FLAG => {
- ESCAPE_SLASH => 0x00000010,
- ALLOW_BIGNUM => 0x00000020,
- AS_NONBLESSED => 0x00000040,
- EXPANDED => 0x10000000, # for developer's
- };
-
- use constant UNSUPPORTED_DECODE_FLAG => {
- LOOSE => 0x00000001,
- ALLOW_BIGNUM => 0x00000002,
- ALLOW_BAREKEY => 0x00000004,
- ALLOW_SINGLEQUOTE => 0x00000008,
- EXPANDED => 0x20000000, # for developer's
- };
-
-
sub init {
- local $^W;
- no strict qw(refs);
- *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"};
- *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"};
- *{"JSON::XS::is_xs"} = sub { 1 };
- *{"JSON::XS::is_pp"} = sub { 0 };
- return 1;
- }
-
-
- sub support_by_pp {
- my ($class, @methods) = @_;
+ my ($class, $module) = @_;
local $^W;
no strict qw(refs);
+ *{"JSON::decode_json"} = \&{"$module\::decode_json"};
+ *{"JSON::encode_json"} = \&{"$module\::encode_json"};
+ *{"JSON::is_bool"} = \&{"$module\::is_bool"};
- my $JSON_XS_encode_orignal = \&JSON::XS::encode;
- my $JSON_XS_decode_orignal = \&JSON::XS::decode;
- my $JSON_XS_incr_parse_orignal = \&JSON::XS::incr_parse;
-
- *JSON::XS::decode = \&JSON::Backend::XS::Supportable::_decode;
- *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
- *JSON::XS::incr_parse = \&JSON::Backend::XS::Supportable::_incr_parse;
-
- *{JSON::XS::_original_decode} = $JSON_XS_decode_orignal;
- *{JSON::XS::_original_encode} = $JSON_XS_encode_orignal;
- *{JSON::XS::_original_incr_parse} = $JSON_XS_incr_parse_orignal;
-
- push @JSON::Backend::XS::Supportable::ISA, 'JSON';
-
- my $pkg = 'JSON::Backend::XS::Supportable';
-
- *{JSON::new} = sub {
- my $proto = JSON::XS->new; $$proto = 0;
- bless $proto, $pkg;
- };
-
-
- for my $method (@methods) {
- my $flag = uc($method);
- my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0);
- $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0);
+ $JSON::true = ${"$module\::true"};
+ $JSON::false = ${"$module\::false"};
- next unless($type);
+ push @JSON::Backend::XS::ISA, $module;
+ push @JSON::ISA, $class;
+ $JSON::Backend = $class;
+ $JSON::BackendModule = $module;
+ ${"$class\::VERSION"} = $module->VERSION;
- $pkg->_make_unsupported_method($method => $type);
+ if ( $module->VERSION < 3 ) {
+ eval 'package JSON::PP::Boolean';
+ push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
}
- # push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean);
- # push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean);
-
- $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
+ for my $method (@PPOnlyMethods) {
+ *{"JSON::$method"} = sub {
+ Carp::carp("$method is not supported in $module.");
+ $_[0];
+ };
+ }
return 1;
}
+ sub is_xs { 1 };
+ sub is_pp { 0 };
+ sub support_by_pp {
+ my ($class, @methods) = @_;
-
- #
- # Helper classes for XS
- #
-
- package JSON::Backend::XS::Supportable;
-
- $Carp::Internal{'JSON::Backend::XS::Supportable'} = 1;
-
- sub _make_unsupported_method {
- my ($pkg, $method, $type) = @_;
+ JSON::__load_pp('JSON::PP');
local $^W;
no strict qw(refs);
- *{"$pkg\::$method"} = sub {
- local $^W;
- if (defined $_[1] ? $_[1] : 1) {
- ${$_[0]} |= $type;
- }
- else {
- ${$_[0]} &= ~$type;
- }
- $_[0];
- };
-
- *{"$pkg\::get_$method"} = sub {
- ${$_[0]} & $type ? 1 : '';
- };
-
- }
-
-
- sub _set_for_pp {
- JSON::_load_pp( $_INSTALL_ONLY );
-
- my $type = shift;
- my $pp = JSON::PP->new;
- my $prop = $_[0]->property;
-
- for my $name (keys %$prop) {
- $pp->$name( $prop->{$name} ? $prop->{$name} : 0 );
- }
-
- my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG
- : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG;
- my $flags = ${$_[0]} || 0;
-
- for my $name (keys %$unsupported) {
- next if ($name eq 'EXPANDED'); # for developer's
- my $enable = ($flags & $unsupported->{$name}) ? 1 : 0;
- my $method = lc $name;
- $pp->$method($enable);
- }
-
- $pp->indent_length( $_[0]->get_indent_length );
-
- return $pp;
- }
-
- sub _encode { # using with PP encode
- if (${$_[0]}) {
- _set_for_pp('encode' => @_)->encode($_[1]);
- }
- else {
- $_[0]->_original_encode( $_[1] );
- }
- }
-
-
- sub _decode { # if unsupported-flag is set, use PP
- if (${$_[0]}) {
- _set_for_pp('decode' => @_)->decode($_[1]);
- }
- else {
- $_[0]->_original_decode( $_[1] );
- }
- }
-
-
- sub decode_prefix { # if unsupported-flag is set, use PP
- _set_for_pp('decode' => @_)->decode_prefix($_[1]);
- }
-
-
- sub _incr_parse {
- if (${$_[0]}) {
- _set_for_pp('decode' => @_)->incr_parse($_[1]);
- }
- else {
- $_[0]->_original_incr_parse( $_[1] );
- }
- }
-
-
- sub get_indent_length {
- ${$_[0]} << 4 >> 16;
- }
-
-
- sub indent_length {
- my $length = $_[1];
-
- if (!defined $length or $length > 15 or $length < 0) {
- Carp::carp "The acceptable range of indent_length() is 0 to 15.";
- }
- else {
- local $^W;
- $length <<= 12;
- ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG;
- ${$_[0]} |= $length;
- *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
+ for my $method (@methods) {
+ my $pp_method = JSON::PP->can($method) or next;
+ *{"JSON::$method"} = sub {
+ if (!$_[0]->isa('JSON::PP')) {
+ my $xs_self = $_[0];
+ my $pp_self = JSON::PP->new;
+ for (@Properties) {
+ my $getter = "get_$_";
+ $pp_self->$_($xs_self->$getter);
+ }
+ $_[0] = $pp_self;
+ }
+ $pp_method->(@_);
+ };
}
- $_[0];
+ $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
}
-
1;
__END__
@@ -58859,247 +61133,212 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$perl_scalar = $json->decode( $json_text );
$pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
-
- # If you want to use PP only support features, call with '-support_by_pp'
- # When XS unsupported feature is enable, using PP (de|en)code instead of XS ones.
-
- use JSON -support_by_pp;
-
- # option-acceptable interfaces (expect/generate UNICODE by default)
-
- $json_text = to_json( $perl_scalar, { ascii => 1, pretty => 1 } );
- $perl_scalar = from_json( $json_text, { utf8 => 1 } );
-
- # Between (en|de)code_json and (to|from)_json, if you want to write
- # a code which communicates to an outer world (encoded in UTF-8),
- # recommend to use (en|de)code_json.
-
- =head1 VERSION
-
- 2.90
-
- This version is compatible with JSON::XS B<2.34> and later.
- (Not yet compatble to JSON::XS B<3.0x>.)
-
-
- =head1 NOTE
-
- JSON::PP was earlier included in the C<JSON> distribution, but
- has since Perl 5.14 been a core module. For this reason,
- L<JSON::PP> was removed from the JSON distribution and can now
- be found also in the Perl5 repository at
- =over
+ =head1 VERSION
- =item * L<http://perl5.git.perl.org/perl.git>
+ 2.93
- =back
+ =head1 DESCRIPTION
- (The newest JSON::PP version still exists in CPAN.)
+ This module is a thin wrapper for L<JSON::XS>-compatible modules with a few
+ additional features. All the backend modules convert a Perl data structure
+ to a JSON text as of RFC4627 (which we know is obsolete but we still stick
+ to; see below for an option to support part of RFC7159) and vice versa.
+ This module uses L<JSON::XS> by default, and when JSON::XS is not available,
+ this module falls back on L<JSON::PP>, which is in the Perl core since 5.14.
+ If JSON::PP is not available either, this module then falls back on
+ JSON::backportPP (which is actually JSON::PP in a different .pm file)
+ bundled in the same distribution as this module. You can also explicitly
+ specify to use L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban.
- Instead, the C<JSON> distribution will include JSON::backportPP
- for backwards computability. JSON.pm should thus work as it did
- before.
+ All these backend modules have slight incompatibilities between them,
+ including extra features that other modules don't support, but as long as you
+ use only common features (most important ones are described below), migration
+ from backend to backend should be reasonably easy. For details, see each
+ backend module you use.
- =head1 DESCRIPTION
+ =head1 CHOOSING BACKEND
- *************************** CAUTION **************************************
- * *
- * INCOMPATIBLE CHANGE (JSON::XS version 2.90) *
- * *
- * JSON.pm had patched JSON::XS::Boolean and JSON::PP::Boolean internally *
- * on loading time for making these modules inherit JSON::Boolean. *
- * But since JSON::XS v3.0 it use Types::Serialiser as boolean class. *
- * Then now JSON.pm breaks boolean classe overload features and *
- * -support_by_pp if JSON::XS v3.0 or later is installed. *
- * *
- * JSON::true and JSON::false returned JSON::Boolean objects. *
- * For workaround, they return JSON::PP::Boolean objects in this version. *
- * *
- * isa_ok(JSON::true, 'JSON::PP::Boolean'); *
- * *
- * And it discards a feature: *
- * *
- * ok(JSON::true eq 'true'); *
- * *
- * In other word, JSON::PP::Boolean overload numeric only. *
- * *
- * ok( JSON::true == 1 ); *
- * *
- **************************************************************************
-
- ************************** CAUTION ********************************
- * This is 'JSON module version 2' and there are many differences *
- * to version 1.xx *
- * Please check your applications using old version. *
- * See to 'INCOMPATIBLE CHANGES TO OLD VERSION' *
- *******************************************************************
-
- JSON (JavaScript Object Notation) is a simple data format.
- See to L<http://www.json.org/> and C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>).
-
- This module converts Perl data structures to JSON and vice versa using either
- L<JSON::XS> or L<JSON::PP>.
-
- JSON::XS is the fastest and most proper JSON module on CPAN which must be
- compiled and installed in your environment.
- JSON::PP is a pure-Perl module which is bundled in this distribution and
- has a strong compatibility to JSON::XS.
-
- This module try to use JSON::XS by default and fail to it, use JSON::PP instead.
- So its features completely depend on JSON::XS or JSON::PP.
-
- See to L<BACKEND MODULE DECISION>.
-
- To distinguish the module name 'JSON' and the format type JSON,
- the former is quoted by CE<lt>E<gt> (its results vary with your using media),
- and the latter is left just as it is.
-
- Module name : C<JSON>
-
- Format type : JSON
+ This module respects an environmental variable called C<PERL_JSON_BACKEND>
+ when it decides a backend module to use. If this environmental variable is
+ not set, it tries to load JSON::XS, and if JSON::XS is not available, it
+ falls back on JSON::PP, and then JSON::backportPP if JSON::PP is not available
+ either.
- =head2 FEATURES
+ If you always don't want it to fall back on pure perl modules, set the
+ variable like this (C<export> may be C<setenv>, C<set> and the likes,
+ depending on your environment):
- =over
+ > export PERL_JSON_BACKEND=JSON::XS
- =item * correct unicode handling
+ If you prefer Cpanel::JSON::XS to JSON::XS, then:
- This module (i.e. backend modules) knows how to handle Unicode, documents
- how and when it does so, and even documents what "correct" means.
+ > export PERL_JSON_BACKEND=Cpanel::JSON::XS,JSON::XS,JSON::PP
- Even though there are limitations, this feature is available since Perl version 5.6.
+ You may also want to set this variable at the top of your test files, in order
+ not to be bothered with incompatibilities between backends (you need to wrap
+ this in C<BEGIN>, and set before actually C<use>-ing JSON module, as it decides
+ its backend as soon as it's loaded):
- JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions
- C<JSON> should call JSON::PP as the backend which can be used since Perl 5.005.
+ BEGIN { $ENV{PERL_JSON_BACKEND}='JSON::backportPP'; }
+ use JSON;
- With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem,
- JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available.
- See to L<JSON::PP/UNICODE HANDLING ON PERLS> for more information.
+ =head1 USING OPTIONAL FEATURES
- See also to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>
- and L<JSON::XS/ENCODING/CODESET_FLAG_NOTES>.
+ There are a few options you can set when you C<use> this module:
+ =over
- =item * round-trip integrity
+ =item -support_by_pp
- When you serialise a perl data structure using only data types supported
- by JSON and Perl, the deserialised data structure is identical on the Perl
- level. (e.g. the string "2.0" doesn't suddenly become "2" just because
- it looks like a number). There I<are> minor exceptions to this, read the
- L</MAPPING> section below to learn about those.
+ BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
+
+ use JSON -support_by_pp;
+
+ my $json = JSON->new;
+ # escape_slash is for JSON::PP only.
+ $json->allow_nonref->escape_slash->encode("/");
+ With this option, this module loads its pure perl backend along with
+ its XS backend (if available), and lets the XS backend to watch if you set
+ a flag only JSON::PP supports. When you do, the internal JSON::XS object
+ is replaced with a newly created JSON::PP object with the setting copied
+ from the XS object, so that you can use JSON::PP flags (and its slower
+ C<decode>/C<encode> methods) from then on. In other words, this is not
+ something that allows you to hook JSON::XS to change its behavior while
+ keeping its speed. JSON::XS and JSON::PP objects are quite different
+ (JSON::XS object is a blessed scalar reference, while JSON::PP object is
+ a blessed hash reference), and can't share their internals.
- =item * strict checking of JSON correctness
+ To avoid needless overhead (by copying settings), you are advised not
+ to use this option and just to use JSON::PP explicitly when you need
+ JSON::PP features.
- There is no guessing, no generating of illegal JSON texts by default,
- and only JSON is accepted as input by default (the latter is a security
- feature).
+ =item -convert_blessed_universally
- See to L<JSON::XS/FEATURES> and L<JSON::PP/FEATURES>.
+ use JSON -convert_blessed_universally;
- =item * fast
+ my $json = JSON->new->allow_nonref->convert_blessed;
+ my $object = bless {foo => 'bar'}, 'Foo';
+ $json->encode($object); # => {"foo":"bar"}
+
+ JSON::XS-compatible backend modules don't encode blessed objects by
+ default (except for their boolean values, which are typically blessed
+ JSON::PP::Boolean objects). If you need to encode a data structure
+ that may contain objects, you usually need to look into the structure
+ and replace objects with alternative non-blessed values, or enable
+ C<convert_blessed> and provide a C<TO_JSON> method for each object's
+ (base) class that may be found in the structure, in order to let the
+ methods replace the objects with whatever scalar values the methods
+ return.
+
+ If you need to serialise data structures that may contain arbitrary
+ objects, it's probably better to use other serialisers (such as
+ L<Sereal> or L<Storable> for example), but if you do want to use
+ this module for that purpose, C<-convert_blessed_universally> option
+ may help, which tweaks C<encode> method of the backend to install
+ C<UNIVERSAL::TO_JSON> method (locally) before encoding, so that
+ all the objects that don't have their own C<TO_JSON> method can
+ fall back on the method in the C<UNIVERSAL> namespace. Note that you
+ still need to enable C<convert_blessed> flag to actually encode
+ objects in a data structure, and C<UNIVERSAL::TO_JSON> method
+ installed by this option only converts blessed hash/array references
+ into their unblessed clone (including private keys/values that are
+ not supposed to be exposed). Other blessed references will be
+ converted into null.
- This module returns a JSON::XS object itself if available.
- Compared to other JSON modules and other serialisers such as Storable,
- JSON::XS usually compares favorably in terms of speed, too.
+ This feature is experimental and may be removed in the future.
- If not available, C<JSON> returns a JSON::PP object instead of JSON::XS and
- it is very slow as pure-Perl.
+ =item -no_export
- =item * simple to use
+ When you don't want to import functional interfaces from a module, you
+ usually supply C<()> to its C<use> statement.
- This module has both a simple functional interface as well as an
- object oriented interface interface.
+ use JSON (); # no functional interfaces
- =item * reasonably versatile output formats
+ If you don't want to import functional interfaces, but you also want to
+ use any of the above options, add C<-no_export> to the option list.
- You can choose between the most compact guaranteed-single-line format possible
- (nice for simple line-based protocols), a pure-ASCII format (for when your transport
- is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed
- format (for when you want to read that stuff). Or you can combine those features
- in whatever way you like.
+ # no functional interfaces, while JSON::PP support is enabled.
+ use JSON -support_by_pp, -no_export;
=back
=head1 FUNCTIONAL INTERFACE
- Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
- C<to_json> and C<from_json> are additional functions.
+ This section is taken from JSON::XS. C<encode_json> and C<decode_json>
+ are exported by default.
+
+ This module also exports C<to_json> and C<from_json> for backward
+ compatibility. These are slower, and may expect/generate different stuff
+ from what C<encode_json> and C<decode_json> do, depending on their
+ options. It's better just to use Object-Oriented interfaces than using
+ these two functions.
=head2 encode_json
$json_text = encode_json $perl_scalar
- Converts the given Perl data structure to a UTF-8 encoded, binary string.
+ Converts the given Perl data structure to a UTF-8 encoded, binary string
+ (that is, the string contains octets only). Croaks on error.
This function call is functionally identical to:
$json_text = JSON->new->utf8->encode($perl_scalar)
+ Except being faster.
+
=head2 decode_json
$perl_scalar = decode_json $json_text
The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference.
+ reference. Croaks on error.
This function call is functionally identical to:
$perl_scalar = JSON->new->utf8->decode($json_text)
+ Except being faster.
=head2 to_json
- $json_text = to_json($perl_scalar)
+ $json_text = to_json($perl_scalar[, $optional_hashref])
- Converts the given Perl data structure to a json string.
+ Converts the given Perl data structure to a Unicode string by default.
+ Croaks on error.
- This function call is functionally identical to:
+ Basically, this function call is functionally identical to:
$json_text = JSON->new->encode($perl_scalar)
- Takes a hash reference as the second.
+ Except being slower.
- $json_text = to_json($perl_scalar, $flag_hashref)
-
- So,
+ You can pass an optional hash reference to modify its behavior, but
+ that may change what C<to_json> expects/generates (see
+ C<ENCODING/CODESET FLAG NOTES> for details).
$json_text = to_json($perl_scalar, {utf8 => 1, pretty => 1})
-
- equivalent to:
-
- $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
-
- If you want to write a modern perl code which communicates to outer world,
- you should use C<encode_json> (supposed that JSON data are encoded in UTF-8).
+ # => JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
=head2 from_json
- $perl_scalar = from_json($json_text)
-
- The opposite of C<to_json>: expects a json string and tries
- to parse it, returning the resulting reference.
-
- This function call is functionally identical to:
+ $perl_scalar = from_json($json_text[, $optional_hashref])
- $perl_scalar = JSON->decode($json_text)
+ The opposite of C<to_json>: expects a Unicode string and tries
+ to parse it, returning the resulting reference. Croaks on error.
- Takes a hash reference as the second.
+ Basically, this function call is functionally identical to:
- $perl_scalar = from_json($json_text, $flag_hashref)
+ $perl_scalar = JSON->new->decode($json_text)
- So,
+ You can pass an optional hash reference to modify its behavior, but
+ that may change what C<from_json> expects/generates (see
+ C<ENCODING/CODESET FLAG NOTES> for details).
$perl_scalar = from_json($json_text, {utf8 => 1})
-
- equivalent to:
-
- $perl_scalar = JSON->new->utf8(1)->decode($json_text)
-
- If you want to write a modern perl code which communicates to outer world,
- you should use C<decode_json> (supposed that JSON data are encoded in UTF-8).
+ # => JSON->new->utf8(1)->decode($json_text)
=head2 JSON::is_bool
@@ -59109,115 +61348,24 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
JSON::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
- =head2 JSON::true
-
- Returns JSON true value which is blessed object.
- It C<isa> JSON::Boolean object.
-
- =head2 JSON::false
-
- Returns JSON false value which is blessed object.
- It C<isa> JSON::Boolean object.
-
- =head2 JSON::null
-
- Returns C<undef>.
-
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
- =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
-
- This section supposes that your perl version is 5.8 or later.
-
- If you know a JSON text from an outer world - a network, a file content, and so on,
- is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
- with C<utf8> enable. And the decoded result will contain UNICODE characters.
-
- # from network
- my $json = JSON->new->utf8;
- my $json_text = CGI->new->param( 'json_data' );
- my $perl_scalar = $json->decode( $json_text );
-
- # from file content
- local $/;
- open( my $fh, '<', 'json.data' );
- $json_text = <$fh>;
- $perl_scalar = decode_json( $json_text );
-
- If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
-
- use Encode;
- local $/;
- open( my $fh, '<', 'json.data' );
- my $encoding = 'cp932';
- my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
-
- # or you can write the below code.
- #
- # open( my $fh, "<:encoding($encoding)", 'json.data' );
- # $unicode_json_text = <$fh>;
-
- In this case, C<$unicode_json_text> is of course UNICODE string.
- So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable or C<from_json>.
-
- $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
- # or
- $perl_scalar = from_json( $unicode_json_text );
-
- Or C<encode 'utf8'> and C<decode_json>:
-
- $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
- # this way is not efficient.
-
- And now, you want to convert your C<$perl_scalar> into JSON data and
- send it to an outer world - a network or a file content, and so on.
-
- Your data usually contains UNICODE strings and you want the converted data to be encoded
- in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
-
- print encode_json( $perl_scalar ); # to a network? file? or display?
- # or
- print $json->utf8->encode( $perl_scalar );
-
- If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
- for some reason, then its characters are regarded as B<latin1> for perl
- (because it does not concern with your $encoding).
- You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable or C<to_json>.
- Note that the resulted text is a UNICODE string but no problem to print it.
-
- # $perl_scalar contains $encoding encoded string values
- $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
- # or
- $unicode_json_text = to_json( $perl_scalar );
- # $unicode_json_text consists of characters less than 0x100
- print $unicode_json_text;
-
- Or C<decode $encoding> all string values and C<encode_json>:
-
- $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
- # ... do it to each string values, then encode_json
- $json_text = encode_json( $perl_scalar );
-
- This method is a proper way but probably not efficient.
-
- See to L<Encode>, L<perluniintro>.
+ =head1 COMMON OBJECT-ORIENTED INTERFACE
+ This section is also taken from JSON::XS.
- =head1 COMMON OBJECT-ORIENTED INTERFACE
+ The object oriented interface lets you configure your own encoding or
+ decoding style, within the limits of supported formats.
=head2 new
$json = JSON->new
- Returns a new C<JSON> object inherited from either JSON::XS or JSON::PP
- that can be used to de/encode JSON strings.
-
- All boolean flags described below are by default I<disabled>.
+ Creates a new JSON::XS-compatible backend object that can be used to de/encode JSON
+ strings. All boolean flags described below are by default I<disabled>.
- The mutators for flags all return the JSON object again and thus calls can
+ The mutators for flags all return the backend object again and thus calls can
be chained:
my $json = JSON->new->utf8->space_after->encode({a => [1,2]})
@@ -59229,16 +61377,23 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_ascii
- If $enable is true (or missing), then the encode method will not generate characters outside
- the code range 0..127. Any Unicode characters outside that range will be escaped using either
- a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
+ If C<$enable> is true (or missing), then the C<encode> method will not
+ generate characters outside the code range C<0..127> (which is ASCII). Any
+ Unicode characters outside that range will be escaped using either a
+ single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
+ as per RFC4627. The resulting encoded JSON text can be treated as a native
+ Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
+ or any other superset of ASCII.
- If $enable is false, then the encode method will not escape Unicode characters unless
- required by the JSON syntax or other flags. This results in a faster and more compact format.
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags. This results
+ in a faster and more compact format.
- This feature depends on the used Perl version and environment.
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
- See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
+ The main use for this flag is to produce JSON texts that can be
+ transmitted over a 7-bit channel, as the encoded JSON texts will not
+ contain any 8 bit characters.
JSON->new->ascii(1)->encode([chr 0x10401])
=> ["\ud801\udc01"]
@@ -59249,11 +61404,25 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_latin1
- If $enable is true (or missing), then the encode method will encode the resulting JSON
- text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
+ outside the code range C<0..255>. The resulting string can be treated as a
+ latin1-encoded JSON text or a native Unicode string. The C<decode> method
+ will not be affected in any way by this flag, as C<decode> by default
+ expects Unicode, which is a strict superset of latin1.
+
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags.
+
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
- If $enable is false, then the encode method will not escape Unicode characters
- unless required by the JSON syntax or other flags.
+ The main use for this flag is efficiently encoding binary data as JSON
+ text, as most octets will not be escaped, resulting in a smaller encoded
+ size. The disadvantage is that the resulting JSON text is encoded
+ in latin1 (and must correctly be treated as such when storing and
+ transferring), a rare encoding for JSON. It is therefore most useful when
+ you want to store data structures known to contain binary data efficiently
+ in files or databases, not when talking to other JSON encoders/decoders.
JSON->new->latin1->encode (["\x{89}\x{abc}"]
=> ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
@@ -59264,31 +61433,30 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_utf8
- If $enable is true (or missing), then the encode method will encode the JSON result
- into UTF-8, as required by many protocols, while the decode method expects to be handled
- an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
- characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
-
- In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
- encoding families, as described in RFC4627.
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the JSON result into UTF-8, as required by many protocols, while the
+ C<decode> method expects to be handled an UTF-8-encoded string. Please
+ note that UTF-8-encoded strings do not contain any characters outside the
+ range C<0..255>, they are thus useful for bytewise/binary I/O. In future
+ versions, enabling this option might enable autodetection of the UTF-16
+ and UTF-32 encoding families, as described in RFC4627.
- If $enable is false, then the encode method will return the JSON string as a (non-encoded)
- Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
- (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
+ If C<$enable> is false, then the C<encode> method will return the JSON
+ string as a (non-encoded) Unicode string, while C<decode> expects thus a
+ Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
+ to be done yourself, e.g. using the Encode module.
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
Example, output UTF-16BE-encoded JSON:
use Encode;
- $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
+ $jsontext = encode "UTF-16BE", JSON->new->encode ($object);
Example, decode UTF-32LE-encoded JSON:
use Encode;
- $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
-
- See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
-
+ $object = JSON->new->decode (decode "UTF-32LE", $jsontext);
=head2 pretty
@@ -59298,13 +61466,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
C<space_after> (and in the future possibly more) flags in one call to
generate the most readable (or most compact) form possible.
- Equivalent to:
-
- $json->indent->space_before->space_after
-
- The indent space length is three and JSON::XS cannot change the indent
- space length.
-
=head2 indent
$json = $json->indent([$enable])
@@ -59313,17 +61474,13 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
If C<$enable> is true (or missing), then the C<encode> method will use a multiline
format as output, putting every array member or object/hash key-value pair
- into its own line, identifying them properly.
+ into its own line, indenting them properly.
If C<$enable> is false, no newlines or indenting will be produced, and the
resulting JSON text is guaranteed not to contain any C<newlines>.
This setting has no effect when decoding JSON texts.
- The indent space length is three.
- With JSON::PP, you can also access C<indent_length> to change indent space length.
-
-
=head2 space_before
$json = $json->space_before([$enable])
@@ -59336,13 +61493,13 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
- This setting has no effect when decoding JSON texts.
+ This setting has no effect when decoding JSON texts. You will also
+ most likely combine this setting with C<space_after>.
Example, space_before enabled, space_after and indent disabled:
{"key" :"value"}
-
=head2 space_after
$json = $json->space_after([$enable])
@@ -59363,7 +61520,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
{"key": "value"}
-
=head2 relaxed
$json = $json->relaxed([$enable])
@@ -59413,7 +61569,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
=back
-
=head2 canonical
$json = $json->canonical([$enable])
@@ -59425,7 +61580,8 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
- of the same script).
+ of the same script, and can change even within the same run from 5.18
+ onwards).
This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
@@ -59434,6 +61590,8 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
This setting has no effect when decoding JSON texts.
+ This setting has currently no effect on tied hashes.
+
=head2 allow_nonref
$json = $json->allow_nonref([$enable])
@@ -59450,6 +61608,9 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
+ Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
+ resulting in an invalid JSON text:
+
JSON->new->allow_nonref->encode ("Hello, World!")
=> "Hello, World!"
@@ -59459,18 +61620,17 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_allow_unknown
- If $enable is true (or missing), then "encode" will *not* throw an
+ If C<$enable> is true (or missing), then C<encode> will I<not> throw an
exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON "null" value.
- Note that blessed objects are not included here and are handled
- separately by c<allow_nonref>.
+ example, filehandles) but instead will encode a JSON C<null> value. Note
+ that blessed objects are not included here and are handled separately by
+ c<allow_nonref>.
- If $enable is false (the default), then "encode" will throw an
+ If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters anything it cannot encode as JSON.
- This option does not affect "decode" in any way, and it is
- recommended to leave it off unless you know your communications
- partner.
+ This option does not affect C<decode> in any way, and it is recommended to
+ leave it off unless you know your communications partner.
=head2 allow_blessed
@@ -59478,16 +61638,17 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_allow_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference. Instead, the value of the
- B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
- disabled or no C<TO_JSON> method found) or a representation of the
- object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
- encoded. Has no effect on C<decode>.
+ barf when it encounters a blessed reference that it cannot convert
+ otherwise. Instead, a JSON C<null> value is encoded instead of the object.
If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object.
+ exception when it encounters a blessed object that it cannot convert
+ otherwise.
+ This setting has no effect on C<decode>.
=head2 convert_blessed
@@ -59495,63 +61656,38 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$enabled = $json->get_convert_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
- on the object's class. If found, it will be called in scalar context
- and the resulting scalar will be encoded instead of the object. If no
- C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
- to do.
+ on the object's class. If found, it will be called in scalar context and
+ the resulting scalar will be encoded instead of the object.
The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
- usually in upper case letters and to avoid collisions with the C<to_json>
+ usually in upper case letters and to avoid collisions with any C<to_json>
function or method.
- This setting does not yet influence C<decode> in any way.
-
- If C<$enable> is false, then the C<allow_blessed> setting will decide what
- to do when a blessed object is found.
-
- =over
-
- =item convert_blessed_universally mode
-
- If use C<JSON> with C<-convert_blessed_universally>, the C<UNIVERSAL::TO_JSON>
- subroutine is defined as the below code:
-
- *UNIVERSAL::TO_JSON = sub {
- my $b_obj = B::svref_2object( $_[0] );
- return $b_obj->isa('B::HV') ? { %{ $_[0] } }
- : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
- : undef
- ;
- }
-
- This will cause that C<encode> method converts simple blessed objects into
- JSON objects as non-blessed object.
-
- JSON -convert_blessed_universally;
- $json->allow_blessed->convert_blessed->encode( $blessed_object )
-
- This feature is experimental and may be removed in the future.
+ If C<$enable> is false (the default), then C<encode> will not consider
+ this type of conversion.
- =back
+ This setting has no effect on C<decode>.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument passed to the coderef
- is a reference to the newly-created hash. If the code references returns
- a single scalar (which need not be a reference), this value
- (i.e. a copy of that scalar to avoid aliasing) is inserted into the
- deserialised data structure. If it returns an empty list
- (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
- hash will be inserted. This setting can slow down decoding considerably.
+ time it decodes a JSON object. The only argument is a reference to the
+ newly-created hash. If the code references returns a single scalar (which
+ need not be a reference), this value (i.e. a copy of that scalar to avoid
+ aliasing) is inserted into the deserialised data structure. If it returns
+ an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
+ original deserialised hash will be inserted. This setting can slow down
+ decoding considerably.
When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
@@ -59566,7 +61702,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
# so a lone 5 is not allowed.
$js->decode ('{"a":1, "b":2}');
-
=head2 filter_json_single_key_object
$json = $json->filter_json_single_key_object($key [=> $coderef])
@@ -59621,27 +61756,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
{ __widget__ => $self->{id} }
}
-
- =head2 shrink
-
- $json = $json->shrink([$enable])
-
- $enabled = $json->get_shrink
-
- With JSON::XS, this flag resizes strings generated by either
- C<encode> or C<decode> to their minimum size possible. This can save
- memory when your JSON texts are either very very long or you have many
- short strings. It will also try to downgrade any strings to octet-form
- if possible: perl stores strings internally either in an encoding called
- UTF-X or in octet-form. The latter cannot store everything but uses less
- space in general (and some buggy Perl or C code might even rely on that
- internal representation being used).
-
- With JSON::PP, it is noop about resizing strings but tries
- C<utf8::downgrade> to the returned string by C<encode>. See to L<utf8>.
-
- See to L<JSON::XS/OBJECT-ORIENTED INTERFACE> and L<JSON::PP/METHODS>.
-
=head2 max_depth
$json = $json->max_depth([$maximum_nesting_depth])
@@ -59658,19 +61772,12 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
characters without their matching closing parenthesis crossed to reach a
given character in a string.
+ Setting the maximum depth to one disallows any nesting, so that ensures
+ that the object is only a single hash/object or array.
+
If no argument is given, the highest possible setting will be used, which
is rarely useful.
- Note that nesting is implemented by recursion in C. The default value has
- been chosen to be as large as typical operating systems allow without
- crashing. (JSON::XS)
-
- With JSON::PP as the backend, when a large value (100 or more) was set and
- it de/encodes a deep nested object/text, it may raise a warning
- 'Deep recursion on subroutine' at the perl runtime phase.
-
- See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
-
=head2 max_size
$json = $json->max_size([$maximum_string_size])
@@ -59686,18 +61793,12 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).
- See L<JSON::XS/SECURITY CONSIDERATIONS>, below, for more info on why this is useful.
-
=head2 encode
$json_text = $json->encode($perl_scalar)
- Converts the given Perl data structure (a simple scalar or a reference
- to a hash or array) to its JSON representation. Simple scalars will be
- converted into JSON string or number sequences, while references to arrays
- become JSON arrays and references to hashes become JSON objects. Undefined
- Perl values (e.g. C<undef>) become JSON C<null> values.
- References to the integers C<0> and C<1> are converted into C<true> and C<false>.
+ Converts the given Perl value or data structure to its JSON
+ representation. Croaks on error.
=head2 decode
@@ -59706,11 +61807,6 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
- JSON numbers and strings become simple Perl scalars. JSON arrays become
- Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
- C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
- C<null> becomes C<undef>.
-
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
@@ -59720,52 +61816,68 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
silently stop parsing there and return the number of characters consumed
so far.
+ This is useful if your JSON texts are not delimited by an outer protocol
+ and you need to know where the JSON text ends.
+
JSON->new->decode_prefix ("[1] the tail")
- => ([], 3)
+ => ([1], 3)
- See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
+ =head1 ADDITIONAL METHODS
- =head2 property
+ The following methods are for this module only.
+
+ =head2 backend
+
+ $backend = $json->backend
+
+ Since 2.92, C<backend> method returns an abstract backend module used currently,
+ which should be JSON::Backend::XS (which inherits JSON::XS or Cpanel::JSON::XS),
+ or JSON::Backend::PP (which inherits JSON::PP), not to monkey-patch the actual
+ backend module globally.
- $boolean = $json->property($property_name)
+ If you need to know what is used actually, use C<isa>, instead of string comparison.
- Returns a boolean value about above some properties.
+ =head2 is_xs
- The available properties are C<ascii>, C<latin1>, C<utf8>,
- C<indent>,C<space_before>, C<space_after>, C<relaxed>, C<canonical>,
- C<allow_nonref>, C<allow_unknown>, C<allow_blessed>, C<convert_blessed>,
- C<shrink>, C<max_depth> and C<max_size>.
+ $boolean = $json->is_xs
- $boolean = $json->property('utf8');
- => 0
- $json->utf8;
- $boolean = $json->property('utf8');
- => 1
+ Returns true if the backend inherits JSON::XS or Cpanel::JSON::XS.
- Sets the property with a given boolean value.
+ =head2 is_pp
- $json = $json->property($property_name => $boolean);
+ $boolean = $json->is_pp
+
+ Returns true if the backend inherits JSON::PP.
+
+ =head2 property
- With no argument, it returns all the above properties as a hash reference.
+ $settings = $json->property()
- $flag_hashref = $json->property();
+ Returns a reference to a hash that holds all the common flag settings.
+
+ $json = $json->property('utf8' => 1)
+ $value = $json->property('utf8') # 1
+
+ You can use this to get/set a value of a particular flag.
=head1 INCREMENTAL PARSING
- Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
+ This section is also taken from JSON::XS.
- In some cases, there is the need for incremental parsing of JSON texts.
- This module does allow you to parse a JSON stream incrementally.
- It does so by accumulating text until it has a full JSON object, which
- it then can decode. This process is similar to using C<decode_prefix>
- to see if a full JSON object is available, but is much more efficient
- (and can be implemented with a minimum of method calls).
+ In some cases, there is the need for incremental parsing of JSON
+ texts. While this module always has to keep both JSON text and resulting
+ Perl data structure in memory at one time, it does allow you to parse a
+ JSON stream incrementally. It does so by accumulating text until it has
+ a full JSON object, which it then can decode. This process is similar to
+ using C<decode_prefix> to see if a full JSON object is available, but
+ is much more efficient (and can be implemented with a minimum of method
+ calls).
- The backend module will only attempt to parse the JSON text once it is sure it
+ This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
- early as the full parser, for example, it doesn't detect parenthesis
- mismatches. The only thing it guarantees is that it starts decoding as
+ early as the full parser, for example, it doesn't detect mismatched
+ parentheses. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
@@ -59800,13 +61912,14 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
- otherwise. For this to work, there must be no separators between the JSON
- objects or arrays, instead they must be concatenated back-to-back. If
- an error occurs, an exception will be raised as in the scalar context
- case. Note that in this case, any previously-parsed JSON texts will be
- lost.
+ otherwise. For this to work, there must be no separators (other than
+ whitespace) between the JSON objects or arrays, instead they must be
+ concatenated back-to-back. If an error occurs, an exception will be
+ raised as in the scalar context case. Note that in this case, any
+ previously-parsed JSON texts will be lost.
- Example: Parse some JSON arrays/objects in a given string and return them.
+ Example: Parse some JSON arrays/objects in a given string and return
+ them.
my @objs = JSON->new->incr_parse ("[5][7][1,2]");
@@ -59822,27 +61935,26 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
real world conditions). As a special exception, you can also call this
method before having parsed anything.
+ That means you can only use this function to look at or manipulate text
+ before or after complete JSON objects, not while the parser is in the
+ middle of parsing a JSON object.
+
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
- $json->incr_text =~ s/\s*,\s*//;
-
- In Perl 5.005, C<lvalue> attribute is not available.
- You must write codes like the below:
-
- $string = $json->incr_text;
- $string =~ s/\s*,\s*//;
- $json->incr_text( $string );
-
=head2 incr_skip
$json->incr_skip
- This will reset the state of the incremental parser and will remove the
- parsed text from the input buffer. This is useful after C<incr_parse>
- died, in which case the input buffer and incremental parser state is left
- unchanged, to skip the text parsed so far and to reset the parse state.
+ This will reset the state of the incremental parser and will remove
+ the parsed text from the input buffer so far. This is useful after
+ C<incr_parse> died, in which case the input buffer and incremental parser
+ state is left unchanged, to skip the text parsed so far and to reset the
+ parse state.
+
+ The difference to C<incr_reset> is that only text until the parse error
+ occurred is removed.
=head2 incr_reset
@@ -59855,140 +61967,18 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
ignore any trailing data, which means you have to reset the parser after
each successful decode.
- See to L<JSON::XS/INCREMENTAL PARSING> for examples.
-
-
- =head1 JSON::PP SUPPORT METHODS
-
- The below methods are JSON::PP own methods, so when C<JSON> works
- with JSON::PP (i.e. the created object is a JSON::PP object), available.
- See to L<JSON::PP/JSON::PP OWN METHODS> in detail.
-
- If you use C<JSON> with additional C<-support_by_pp>, some methods
- are available even with JSON::XS. See to L<USE PP FEATURES EVEN THOUGH XS BACKEND>.
-
- BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
-
- use JSON -support_by_pp;
-
- my $json = JSON->new;
- $json->allow_nonref->escape_slash->encode("/");
-
- # functional interfaces too.
- print to_json(["/"], {escape_slash => 1});
- print from_json('["foo"]', {utf8 => 1});
-
- If you do not want to all functions but C<-support_by_pp>,
- use C<-no_export>.
-
- use JSON -support_by_pp, -no_export;
- # functional interfaces are not exported.
-
- =head2 allow_singlequote
-
- $json = $json->allow_singlequote([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- any JSON strings quoted by single quotations that are invalid JSON
- format.
-
- $json->allow_singlequote->decode({"foo":'bar'});
- $json->allow_singlequote->decode({'foo':"bar"});
- $json->allow_singlequote->decode({'foo':'bar'});
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
- =head2 allow_barekey
-
- $json = $json->allow_barekey([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- bare keys of JSON object that are invalid JSON format.
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
- $json->allow_barekey->decode('{foo:"bar"}');
-
- =head2 allow_bignum
-
- $json = $json->allow_bignum([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will convert
- the big integer Perl cannot handle as integer into a L<Math::BigInt>
- object and convert a floating number (any) into a L<Math::BigFloat>.
-
- On the contrary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers with C<allow_blessed> enable.
-
- $json->allow_nonref->allow_blessed->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
-
- See to L<MAPPING> about the conversion of JSON number.
-
- =head2 loose
-
- $json = $json->loose([$enable])
-
- The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
- and the module doesn't allow to C<decode> to these (except for \x2f).
- If C<$enable> is true (or missing), then C<decode> will accept these
- unescaped strings.
-
- $json->loose->decode(qq|["abc
- def"]|);
-
- See to L<JSON::PP/JSON::PP OWN METHODS>.
-
- =head2 escape_slash
-
- $json = $json->escape_slash([$enable])
-
- According to JSON Grammar, I<slash> (U+002F) is escaped. But by default
- JSON backend modules encode strings without escaping slash.
-
- If C<$enable> is true (or missing), then C<encode> will escape slashes.
-
- =head2 indent_length
-
- $json = $json->indent_length($length)
-
- With JSON::XS, The indent space length is 3 and cannot be changed.
- With JSON::PP, it sets the indent space length with the given $length.
- The default is 3. The acceptable range is 0 to 15.
-
- =head2 sort_by
-
- $json = $json->sort_by($function_name)
- $json = $json->sort_by($subroutine_ref)
-
- If $function_name or $subroutine_ref are set, its sort routine are used.
-
- $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- $js = $pc->sort_by('own_sort')->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
-
- As the sorting routine runs in the JSON::PP scope, the given
- subroutine name and the special variables C<$a>, C<$b> will begin
- with 'JSON::PP::'.
-
- If $integer is set, then the effect is same as C<canonical> on.
-
- See to L<JSON::PP/JSON::PP OWN METHODS>.
-
=head1 MAPPING
- This section is copied from JSON::XS and modified to C<JSON>.
- JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
+ Most of this section is also taken from JSON::XS.
- See to L<JSON::XS/MAPPING>.
+ This section describes how the backend modules map Perl values to JSON values and
+ vice versa. These mappings are designed to "do the right thing" in most
+ circumstances automatically, preserving round-tripping characteristics
+ (what you put in comes out as something equivalent).
+
+ For the more enlightened: note that in the following descriptions,
+ lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
+ refers to the abstract Perl language itself.
=head2 JSON -> PERL
@@ -60017,7 +62007,7 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.
- If the number consists of digits only, C<JSON> will try to represent
+ If the number consists of digits only, this module will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
@@ -60031,13 +62021,9 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
- floating point, C<JSON> only guarantees precision up to but not including
+ floating point, this module only guarantees precision up to but not including
the least significant bit.
- If the backend is JSON::PP and C<allow_bignum> is enable, the big integers
- and the numeric can be optionally converted into L<Math::BigInt> and
- L<Math::BigFloat> objects.
-
=item true, false
These JSON atoms become C<JSON::true> and C<JSON::false>,
@@ -60045,20 +62031,15 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
the C<JSON::is_bool> function.
- print JSON::true + 1;
- => 1
-
- ok(JSON::true eq '1');
- ok(JSON::true == 1);
-
- C<JSON> will install these missing overloading features to the backend modules.
-
-
=item null
A JSON null atom becomes C<undef> in Perl.
- C<JSON::null> returns C<undef>.
+ =item shell-style comments (C<< # I<text> >>)
+
+ As a nonstandard extension to the JSON syntax that is enabled by the
+ C<relaxed> setting, shell-style comments are allowed. They can start
+ anywhere outside strings and go till the end of the line.
=back
@@ -60073,18 +62054,13 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
=item hash references
- Perl hash references become JSON objects. As there is no inherent ordering
- in hash keys (or JSON objects), they will usually be encoded in a
- pseudo-random order that can change between runs of the same program but
- stays generally the same within a single run of a program. C<JSON>
- optionally sort the hash keys (determined by the I<canonical> flag), so
- the same data structure will serialise to the same JSON text (given same
- settings and version of JSON::XS), but this incurs a runtime overhead
- and is only rarely useful, e.g. when you want to compare some JSON text
- against another for equality.
-
- In future, the ordered object feature will be added to JSON::PP using C<tie> mechanism.
-
+ Perl hash references become JSON objects. As there is no inherent
+ ordering in hash keys (or JSON objects), they will usually be encoded
+ in a pseudo-random order. This module can optionally sort the hash keys
+ (determined by the I<canonical> flag), so the same data structure will
+ serialise to the same JSON text (given same settings and version of
+ the same backend), but this incurs a runtime overhead and is only rarely useful,
+ e.g. when you want to compare some JSON text against another for equality.
=item array references
@@ -60097,36 +62073,23 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
also use C<JSON::false> and C<JSON::true> to improve readability.
- to_json [\0,JSON::true] # yields [false,true]
+ encode_json [\0,JSON::true] # yields [false,true]
=item JSON::true, JSON::false, JSON::null
These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.
- JSON::null returns C<undef>.
-
=item blessed objects
- Blessed objects are not directly representable in JSON. See the
- C<allow_blessed> and C<convert_blessed> methods on various options on
- how to deal with this: basically, you can choose between throwing an
- exception, encoding the reference as if it weren't blessed, or provide
- your own serialiser method.
-
- With C<convert_blessed_universally> mode, C<encode> converts blessed
- hash references or blessed array references (contains other blessed references)
- into JSON members and arrays.
-
- use JSON -convert_blessed_universally;
- JSON->new->allow_blessed->convert_blessed->encode( $blessed_object );
-
- See to L<convert_blessed>.
+ Blessed objects are not directly representable in JSON, but C<JSON::XS>
+ allows various ways of handling objects. See L<OBJECT SERIALISATION>,
+ below, for details.
=item simple scalars
Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
+ difficult objects to encode: this module will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:
@@ -60155,7 +62118,9 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
$x += 0; # numify it, ensuring it will be dumped as a number
$x *= 1; # same thing, the choice is yours.
- You can not currently force the type in other, less obscure, ways.
+ You can not currently force the type in other, less obscure, ways. Tell me
+ if you need this capability (but don't forget to explain why it's needed
+ :).
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
@@ -60164,352 +62129,185 @@ $fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.
- =item Big Number
-
- If the backend is JSON::PP and C<allow_bignum> is enable,
- C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers.
-
-
=back
- =head1 JSON and ECMAscript
-
- See to L<JSON::XS/JSON and ECMAscript>.
-
- =head1 JSON and YAML
-
- JSON is not a subset of YAML.
- See to L<JSON::XS/JSON and YAML>.
-
-
- =head1 BACKEND MODULE DECISION
-
- When you use C<JSON>, C<JSON> tries to C<use> JSON::XS. If this call failed, it will
- C<uses> JSON::PP. The required JSON::XS version is I<2.2> or later.
-
- The C<JSON> constructor method returns an object inherited from the backend module,
- and JSON::XS object is a blessed scalar reference while JSON::PP is a blessed hash
- reference.
-
- So, your program should not depend on the backend module, especially
- returned objects should not be modified.
-
- my $json = JSON->new; # XS or PP?
- $json->{stash} = 'this is xs object'; # this code may raise an error!
-
- To check the backend module, there are some methods - C<backend>, C<is_pp> and C<is_xs>.
+ =head2 OBJECT SERIALISATION
- JSON->backend; # 'JSON::XS' or 'JSON::PP'
-
- JSON->backend->is_pp: # 0 or 1
-
- JSON->backend->is_xs: # 1 or 0
-
- $json->is_xs; # 1 or 0
-
- $json->is_pp; # 0 or 1
+ As for Perl objects, this module only supports a pure JSON representation
+ (without the ability to deserialise the object automatically again).
+ =head3 SERIALISATION
- If you set an environment variable C<PERL_JSON_BACKEND>, the calling action will be changed.
+ What happens when this module encounters a Perl object depends on the
+ C<allow_blessed> and C<convert_blessed> settings, which are used in
+ this order:
- =over
+ =over 4
- =item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'JSON::PP'
+ =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
- Always use JSON::PP
+ In this case, the C<TO_JSON> method of the object is invoked in scalar
+ context. It must return a single scalar that can be directly encoded into
+ JSON. This scalar replaces the object in the JSON text.
- =item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,JSON::PP'
+ For example, the following C<TO_JSON> method will convert all L<URI>
+ objects to JSON strings when serialised. The fact that these values
+ originally were L<URI> objects is lost.
- (The default) Use compiled JSON::XS if it is properly compiled & installed,
- otherwise use JSON::PP.
+ sub URI::TO_JSON {
+ my ($uri) = @_;
+ $uri->as_string
+ }
- =item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS'
+ =item 2. C<allow_blessed> is enabled.
- Always use compiled JSON::XS, die if it isn't properly compiled & installed.
+ The object will be serialised as a JSON null value.
- =item PERL_JSON_BACKEND = 'JSON::backportPP'
+ =item 3. none of the above
- Always use JSON::backportPP.
- JSON::backportPP is JSON::PP back port module.
- C<JSON> includes JSON::backportPP instead of JSON::PP.
+ If none of the settings are enabled or the respective methods are missing,
+ this module throws an exception.
=back
- These ideas come from L<DBI::PurePerl> mechanism.
-
- example:
-
- BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::PP' }
- use JSON; # always uses JSON::PP
-
- In future, it may be able to specify another module.
-
- =head1 USE PP FEATURES EVEN THOUGH XS BACKEND
-
- Many methods are available with either JSON::XS or JSON::PP and
- when the backend module is JSON::XS, if any JSON::PP specific (i.e. JSON::XS unsupported)
- method is called, it will C<warn> and be noop.
-
- But If you C<use> C<JSON> passing the optional string C<-support_by_pp>,
- it makes a part of those unsupported methods available.
- This feature is achieved by using JSON::PP in C<de/encode>.
-
- BEGIN { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS
- use JSON -support_by_pp;
- my $json = JSON->new;
- $json->allow_nonref->escape_slash->encode("/");
-
- At this time, the returned object is a C<JSON::Backend::XS::Supportable>
- object (re-blessed XS object), and by checking JSON::XS unsupported flags
- in de/encoding, can support some unsupported methods - C<loose>, C<allow_bignum>,
- C<allow_barekey>, C<allow_singlequote>, C<escape_slash> and C<indent_length>.
-
- When any unsupported methods are not enable, C<XS de/encode> will be
- used as is. The switch is achieved by changing the symbolic tables.
-
- C<-support_by_pp> is effective only when the backend module is JSON::XS
- and it makes the de/encoding speed down a bit.
-
- See to L<JSON::PP SUPPORT METHODS>.
-
- =head1 INCOMPATIBLE CHANGES TO OLD VERSION
+ =head1 ENCODING/CODESET FLAG NOTES
- There are big incompatibility between new version (2.00) and old (1.xx).
- If you use old C<JSON> 1.xx in your code, please check it.
+ This section is taken from JSON::XS.
- See to L<Transition ways from 1.xx to 2.xx.>
+ The interested reader might have seen a number of flags that signify
+ encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
+ some confusion on what these do, so here is a short comparison:
- =over
+ C<utf8> controls whether the JSON text created by C<encode> (and expected
+ by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
+ control whether C<encode> escapes character values outside their respective
+ codeset range. Neither of these flags conflict with each other, although
+ some combinations make less sense than others.
- =item jsonToObj and objToJson are obsoleted.
+ Care has been taken to make all flags symmetrical with respect to
+ C<encode> and C<decode>, that is, texts encoded with any combination of
+ these flag values will be correctly decoded when the same flags are used
+ - in general, if you use different flag settings while encoding vs. when
+ decoding you likely have a bug somewhere.
- Non Perl-style name C<jsonToObj> and C<objToJson> are obsoleted
- (but not yet deleted from the source).
- If you use these functions in your code, please replace them
- with C<from_json> and C<to_json>.
+ Below comes a verbose discussion of these flags. Note that a "codeset" is
+ simply an abstract set of character-codepoint pairs, while an encoding
+ takes those codepoint numbers and I<encodes> them, in our case into
+ octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
+ and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
+ the same time, which can be confusing.
+ =over 4
- =item Global variables are no longer available.
+ =item C<utf8> flag disabled
- C<JSON> class variables - C<$JSON::AUTOCONVERT>, C<$JSON::BareKey>, etc...
- - are not available any longer.
- Instead, various features can be used through object methods.
+ When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
+ and expect Unicode strings, that is, characters with high ordinal Unicode
+ values (> 255) will be encoded as such characters, and likewise such
+ characters are decoded as-is, no changes to them will be done, except
+ "(re-)interpreting" them as Unicode codepoints or Unicode characters,
+ respectively (to Perl, these are the same thing in strings unless you do
+ funny/weird/dumb stuff).
+ This is useful when you want to do the encoding yourself (e.g. when you
+ want to have UTF-16 encoded JSON texts) or when some other layer does
+ the encoding for you (for example, when printing to a terminal using a
+ filehandle that transparently encodes to UTF-8 you certainly do NOT want
+ to UTF-8 encode your data first and have Perl encode it another time).
- =item Package JSON::Converter and JSON::Parser are deleted.
+ =item C<utf8> flag enabled
- Now C<JSON> bundles with JSON::PP which can handle JSON more properly than them.
+ If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
+ characters using the corresponding UTF-8 multi-byte sequence, and will
+ expect your input strings to be encoded as UTF-8, that is, no "character"
+ of the input string must have any value > 255, as UTF-8 does not allow
+ that.
- =item Package JSON::NotString is deleted.
+ The C<utf8> flag therefore switches between two modes: disabled means you
+ will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
+ octet/binary string in Perl.
- There was C<JSON::NotString> class which represents JSON value C<true>, C<false>, C<null>
- and numbers. It was deleted and replaced by C<JSON::Boolean>.
+ =item C<latin1> or C<ascii> flags enabled
- C<JSON::Boolean> represents C<true> and C<false>.
+ With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
+ with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
+ characters as specified by the C<utf8> flag.
- C<JSON::Boolean> does not represent C<null>.
+ If C<utf8> is disabled, then the result is also correctly encoded in those
+ character sets (as both are proper subsets of Unicode, meaning that a
+ Unicode string with all character values < 256 is the same thing as a
+ ISO-8859-1 string, and a Unicode string with all character values < 128 is
+ the same thing as an ASCII string in Perl).
- C<JSON::null> returns C<undef>.
+ If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
+ regardless of these flags, just some more characters will be escaped using
+ C<\uXXXX> then before.
- C<JSON> makes L<JSON::XS::Boolean> and L<JSON::PP::Boolean> is-a relation
- to L<JSON::Boolean>.
+ Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
+ encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
+ encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
+ a subset of Unicode), while ASCII is.
- =item function JSON::Number is obsoleted.
+ Surprisingly, C<decode> will ignore these flags and so treat all input
+ values as governed by the C<utf8> flag. If it is disabled, this allows you
+ to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
+ Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
- C<JSON::Number> is now needless because JSON::XS and JSON::PP have
- round-trip integrity.
+ So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
+ they only govern when the JSON output engine escapes a character or not.
- =item JSONRPC modules are deleted.
+ The main use for C<latin1> is to relatively efficiently store binary data
+ as JSON, at the expense of breaking compatibility with most JSON decoders.
- Perl implementation of JSON-RPC protocol - C<JSONRPC >, C<JSONRPC::Transport::HTTP>
- and C<Apache::JSONRPC > are deleted in this distribution.
- Instead of them, there is L<JSON::RPC> which supports JSON-RPC protocol version 1.1.
+ The main use for C<ascii> is to force the output to not contain characters
+ with values > 127, which means you can interpret the resulting string
+ as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
+ 8-bit-encoding, and still get the same data structure back. This is useful
+ when your channel for JSON transfer is not 8-bit clean or the encoding
+ might be mangled in between (e.g. in mail), and works because ASCII is a
+ proper subset of most 8-bit and multibyte encodings in use in the world.
=back
- =head2 Transition ways from 1.xx to 2.xx.
-
- You should set C<suport_by_pp> mode firstly, because
- it is always successful for the below codes even with JSON::XS.
-
- use JSON -support_by_pp;
-
- =over
-
- =item Exported jsonToObj (simple)
-
- from_json($json_text);
-
- =item Exported objToJson (simple)
-
- to_json($perl_scalar);
-
- =item Exported jsonToObj (advanced)
-
- $flags = {allow_barekey => 1, allow_singlequote => 1};
- from_json($json_text, $flags);
-
- equivalent to:
-
- $JSON::BareKey = 1;
- $JSON::QuotApos = 1;
- jsonToObj($json_text);
-
- =item Exported objToJson (advanced)
-
- $flags = {allow_blessed => 1, allow_barekey => 1};
- to_json($perl_scalar, $flags);
-
- equivalent to:
-
- $JSON::BareKey = 1;
- objToJson($perl_scalar);
-
- =item jsonToObj as object method
-
- $json->decode($json_text);
-
- =item objToJson as object method
-
- $json->encode($perl_scalar);
-
- =item new method with parameters
-
- The C<new> method in 2.x takes any parameters no longer.
- You can set parameters instead;
-
- $json = JSON->new->pretty;
-
- =item $JSON::Pretty, $JSON::Indent, $JSON::Delimiter
-
- If C<indent> is enable, that means C<$JSON::Pretty> flag set. And
- C<$JSON::Delimiter> was substituted by C<space_before> and C<space_after>.
- In conclusion:
-
- $json->indent->space_before->space_after;
-
- Equivalent to:
-
- $json->pretty;
-
- To change indent length, use C<indent_length>.
-
- (Only with JSON::PP, if C<-support_by_pp> is not used.)
-
- $json->pretty->indent_length(2)->encode($perl_scalar);
-
- =item $JSON::BareKey
-
- (Only with JSON::PP, if C<-support_by_pp> is not used.)
-
- $json->allow_barekey->decode($json_text)
-
- =item $JSON::ConvBlessed
-
- use C<-convert_blessed_universally>. See to L<convert_blessed>.
-
- =item $JSON::QuotApos
-
- (Only with JSON::PP, if C<-support_by_pp> is not used.)
-
- $json->allow_singlequote->decode($json_text)
-
- =item $JSON::SingleQuote
-
- Disable. C<JSON> does not make such a invalid JSON string any longer.
-
- =item $JSON::KeySort
-
- $json->canonical->encode($perl_scalar)
-
- This is the ascii sort.
-
- If you want to use with your own sort routine, check the C<sort_by> method.
-
- (Only with JSON::PP, even if C<-support_by_pp> is used currently.)
-
- $json->sort_by($sort_routine_ref)->encode($perl_scalar)
-
- $json->sort_by(sub { $JSON::PP::a <=> $JSON::PP::b })->encode($perl_scalar)
-
- Can't access C<$a> and C<$b> but C<$JSON::PP::a> and C<$JSON::PP::b>.
-
- =item $JSON::SkipInvalid
-
- $json->allow_unknown
-
- =item $JSON::AUTOCONVERT
-
- Needless. C<JSON> backend modules have the round-trip integrity.
-
- =item $JSON::UTF8
-
- Needless because C<JSON> (JSON::XS/JSON::PP) sets
- the UTF8 flag on properly.
-
- # With UTF8-flagged strings
-
- $json->allow_nonref;
- $str = chr(1000); # UTF8-flagged
-
- $json_text = $json->utf8(0)->encode($str);
- utf8::is_utf8($json_text);
- # true
- $json_text = $json->utf8(1)->encode($str);
- utf8::is_utf8($json_text);
- # false
-
- $str = '"' . chr(1000) . '"'; # UTF8-flagged
-
- $perl_scalar = $json->utf8(0)->decode($str);
- utf8::is_utf8($perl_scalar);
- # true
- $perl_scalar = $json->utf8(1)->decode($str);
- # died because of 'Wide character in subroutine'
-
- See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
+ =head1 BACKWARD INCOMPATIBILITY
- =item $JSON::UnMapping
+ Since version 2.90, stringification (and string comparison) for
+ C<JSON::true> and C<JSON::false> has not been overloaded. It shouldn't
+ matter as long as you treat them as boolean values, but a code that
+ expects they are stringified as "true" or "false" doesn't work as
+ you have expected any more.
- Disable. See to L<MAPPING>.
+ if (JSON::true eq 'true') { # now fails
- =item $JSON::SelfConvert
+ print "The result is $JSON::true now."; # => The result is 1 now.
- This option was deleted.
- Instead of it, if a given blessed object has the C<TO_JSON> method,
- C<TO_JSON> will be executed with C<convert_blessed>.
+ And now these boolean values don't inherit JSON::Boolean, either.
+ When you need to test a value is a JSON boolean value or not, use
+ C<JSON::is_bool> function, instead of testing the value inherits
+ a particular boolean class or not.
- $json->convert_blessed->encode($blessed_hashref_or_arrayref)
- # if need, call allow_blessed
+ =head1 BUGS
- Note that it was C<toJson> in old version, but now not C<toJson> but C<TO_JSON>.
+ Please report bugs on backend selection and additional features
+ this module provides to RT or GitHub issues for this module:
- =back
+ =over 4
- =head1 TODO
+ =item https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON
- =over
-
- =item example programs
+ =item https://github.com/makamaka/JSON/issues
=back
- =head1 THREADS
-
- No test with JSON::PP. If with JSON::XS, See to L<JSON::XS/THREADS>.
-
-
- =head1 BUGS
-
- Please report bugs relevant to C<JSON> to E<lt>makamaka[at]cpan.orgE<gt>.
-
+ Please report bugs and feature requests on decoding/encoding
+ and boolean behaviors to the author of the backend module you
+ are using.
=head1 SEE ALSO
- Most of the document is copied and modified from JSON::XS doc.
+ L<JSON::XS>, L<Cpanel::JSON::XS>, L<JSON::PP> for backends.
- L<JSON::XS>, L<JSON::PP>
+ L<JSON::MaybeXS>, an alternative that prefers Cpanel::JSON::XS.
C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>)
@@ -60540,14 +62338,17 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use 5.005;
use strict;
- use base qw(Exporter);
+
+ use Exporter ();
+ BEGIN { @JSON::PP::ISA = ('Exporter') }
+
use overload ();
+ use JSON::PP::Boolean;
use Carp ();
- use B ();
#use Devel::Peek;
- $JSON::PP::VERSION = '2.27203';
+ $JSON::PP::VERSION = '2.94';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -60577,6 +62378,13 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use constant P_ALLOW_UNKNOWN => 18;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
+ use constant USE_B => 0;
+
+ BEGIN {
+ if (USE_B) {
+ require B;
+ }
+ }
BEGIN {
my @xs_compati_bit_properties = qw(
@@ -60588,33 +62396,33 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
allow_barekey escape_slash as_nonblessed
);
- # Perl version check, Unicode handling is enable?
+ # Perl version check, Unicode handling is enabled?
# Helper module sets @JSON::PP::_properties.
- if ($] < 5.008 ) {
+ if ( OLD_PERL ) {
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);
+ my $property_id = 'P_' . uc($name);
eval qq/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
if (\$enable) {
- \$_[0]->{PROPS}->[$flag_name] = 1;
+ \$_[0]->{PROPS}->[$property_id] = 1;
}
else {
- \$_[0]->{PROPS}->[$flag_name] = 0;
+ \$_[0]->{PROPS}->[$property_id] = 0;
}
\$_[0];
}
sub get_$name {
- \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
+ \$_[0]->{PROPS}->[$property_id] ? 1 : '';
}
/;
}
@@ -60625,16 +62433,6 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
# Functions
- my %encode_allow_method
- = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
- allow_blessed convert_blessed indent indent_length allow_bignum
- as_nonblessed
- /;
- my %decode_allow_method
- = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
- allow_barekey max_size relaxed/;
-
-
my $JSON; # cache
sub encode_json ($) { # encode
@@ -60665,9 +62463,6 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
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,
};
@@ -60700,7 +62495,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $enable = defined $v ? $v : 1;
if ($enable) { # indent_length(3) for JSON::XS compatibility
- $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
+ $self->indent(1)->space_before(1)->space_after(1);
}
else {
$self->indent(0)->space_before(0)->space_after(0);
@@ -60732,14 +62527,24 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub filter_json_object {
- $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
+ if (defined $_[1] and ref $_[1] eq 'CODE') {
+ $_[0]->{cb_object} = $_[1];
+ } else {
+ delete $_[0]->{cb_object};
+ }
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub filter_json_single_key_object {
- if (@_ > 1) {
+ if (@_ == 1 or @_ > 3) {
+ Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
+ }
+ if (defined $_[2] and ref $_[2] eq 'CODE') {
$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
+ } else {
+ delete $_[0]->{cb_sk_object}->{$_[1]};
+ delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
}
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
@@ -60765,7 +62570,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
sub allow_bigint {
- Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
+ Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
+ $_[0]->allow_bignum;
}
###############################
@@ -60805,11 +62611,11 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$indent_count = 0;
$depth = 0;
- my $idx = $self->{PROPS};
+ my $props = $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,
+ = @{$props}[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/};
@@ -60823,7 +62629,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
- if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
+ if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
my $str = $self->object_to_json($obj);
@@ -60833,7 +62639,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
utf8::upgrade($str);
}
- if ($idx->[ P_SHRINK ]) {
+ if ($props->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
@@ -60871,13 +62677,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
return "$obj" if ( $bignum and _is_bignum($obj) );
- return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
+ if ($allow_blessed) {
+ return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
+ return 'null';
+ }
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);
@@ -60901,15 +62708,16 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
for my $k ( _sort( $obj ) ) {
if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
- push @res, string_to_json( $self, $k )
+ push @res, $self->string_to_json( $k )
. $del
- . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
+ . ( ref $obj->{$k} ? $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 : '' ) . '}';
+ return '{}' unless @res;
+ return '{' . $pre . join( ",$pre", @res ) . $post . '}';
}
@@ -60923,36 +62731,53 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
for my $v (@$obj){
- push @res, $self->object_to_json($v) || $self->value_to_json($v);
+ push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
}
--$depth;
$self->_down_indent() if ($indent);
- return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
+ return '[]' unless @res;
+ return '[' . $pre . join( ",$pre", @res ) . $post . ']';
}
+ sub _looks_like_number {
+ my $value = shift;
+ if (USE_B) {
+ my $b_obj = B::svref_2object(\$value);
+ my $flags = $b_obj->FLAGS;
+ return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
+ return;
+ } else {
+ no warnings 'numeric';
+ # detect numbers
+ # string & "" -> ""
+ # number & "" -> 0 (with warning)
+ # nan and inf can detect as numbers, so check with * 0
+ return unless length((my $dummy = "") & $value);
+ return unless 0 + $value eq $value;
+ return 1 if $value * 0 == 0;
+ return -1; # inf/nan
+ }
+ }
sub value_to_json {
my ($self, $value) = @_;
return 'null' if(!defined $value);
- my $b_obj = B::svref_2object(\$value); # for round trip problem
- my $flags = $b_obj->FLAGS;
-
- return $value # as is
- if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
-
my $type = ref($value);
- if(!$type){
- return string_to_json($self, $value);
+ if (!$type) {
+ if (_looks_like_number($value)) {
+ return $value;
+ }
+ return $self->string_to_json($value);
}
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
return $$value == 1 ? 'true' : 'false';
}
- elsif ($type) {
+ else {
if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
return $self->value_to_json("$value");
}
@@ -60964,25 +62789,19 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
: encode_error("cannot encode reference to scalar");
}
- if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
- return 'null';
- }
- else {
- if ( $type eq 'SCALAR' or $type eq 'REF' ) {
+ 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 {
+ }
+ 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';
- }
-
}
@@ -61144,7 +62963,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $text; # json data
my $at; # offset
- my $ch; # 1chracter
+ my $ch; # first character
my $len; # text length (changed according to UTF8 or NON UTF8)
# INTERNAL
my $depth; # nest counter
@@ -61153,7 +62972,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $utf8_len; # utf8 byte length
# FLAGS
my $utf8; # must be utf8
- my $max_depth; # max nest nubmer of objects and arrays
+ my $max_depth; # max nest number of objects and arrays
my $max_size;
my $relaxed;
my $cb_object;
@@ -61161,19 +62980,27 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $F_HOOK;
- my $allow_bigint; # using Math::BigInt
+ my $allow_bignum; # using Math::BigInt/BigFloat
my $singlequote; # loosely quoting
my $loose; #
my $allow_barekey; # bareKey
- # $opt flag
- # 0x00000001 .... decode_prefix
- # 0x10000000 .... incr_parse
+ sub _detect_utf_encoding {
+ my $text = shift;
+ my @octets = unpack('C4', $text);
+ return 'unknown' unless defined $octets[3];
+ return ( $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';
+ }
sub PP_decode_json {
- my ($self, $opt); # $opt is an effective flag during this decode_json.
+ my ($self, $want_offset);
- ($self, $text, $opt) = @_;
+ ($self, $text, $want_offset) = @_;
($at, $ch, $depth) = (0, '', 0);
@@ -61181,16 +63008,23 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
- my $idx = $self->{PROPS};
+ my $props = $self->{PROPS};
- ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
- = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
+ ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote)
+ = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
if ( $utf8 ) {
- utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
+ $encoding = _detect_utf_encoding($text);
+ if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
+ require Encode;
+ Encode::from_to($text, $encoding, 'utf-8');
+ } else {
+ utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
+ }
}
else {
utf8::upgrade( $text );
+ utf8::encode( $text );
}
$len = length $text;
@@ -61207,27 +63041,13 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
) if ($bytes > $max_size);
}
- # Currently no effect
- # should use regexp
- my @octets = unpack('C4', $text);
- $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
- : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
- : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
- : ( $octets[2] ) ? 'UTF-16LE'
- : (!$octets[2] ) ? 'UTF-32LE'
- : 'unknown';
-
white(); # remove head white space
- my $valid_start = defined $ch; # Is there a first character for JSON structure?
+ decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
my $result = value();
- return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
-
- decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
-
- if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
+ if ( !$props->[ 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);
@@ -61239,12 +63059,11 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
white(); # remove tail white space
- if ( $ch ) {
- return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
- decode_error("garbage after JSON object");
- }
+ return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
- ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
+ decode_error("garbage after JSON object") if defined $ch;
+
+ $result;
}
@@ -61265,13 +63084,12 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
sub string {
- my ($i, $s, $t, $u);
my $utf16;
my $is_utf8;
($is_valid_utf8, $utf8_len) = ('', 0);
- $s = ''; # basically UTF8 flag on
+ my $s = ''; # basically UTF8 flag on
if($ch eq '"' or ($singlequote and $ch eq "'")){
my $boundChar = $ch;
@@ -61342,17 +63160,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;
@@ -61376,10 +63189,10 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub white {
while( defined $ch ){
- if($ch le ' '){
+ if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
next_chr();
}
- elsif($ch eq '/'){
+ elsif($relaxed and $ch eq '/'){
next_chr();
if(defined $ch and $ch eq '/'){
1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
@@ -61470,6 +63283,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
}
+ $at-- if defined $ch and $ch ne '';
decode_error(", or ] expected while parsing array");
}
@@ -61536,7 +63350,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
- $at--;
+ $at-- if defined $ch and $ch ne '';
decode_error(", or } expected while parsing object/hash");
}
@@ -61585,32 +63399,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub number {
my $n = '';
my $v;
-
- # According to RFC4627, hex or oct digts are invalid.
- if($ch eq '0'){
- my $peek = substr($text,$at,1);
- my $hex = $peek =~ /[xX]/; # 0 or 1
-
- if($hex){
- decode_error("malformed number (leading zero must not be followed by another digit)");
- ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
- }
- else{ # oct
- ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
- if (defined $n and length $n > 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- }
-
- if(defined $n and length($n)){
- if (!$hex and length($n) == 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- $at += length($n) + $hex;
- next_chr;
- return $hex ? hex($n) : oct($n);
- }
- }
+ my $is_dec;
+ my $is_exp;
if($ch eq '-'){
$n = '-';
@@ -61620,6 +63410,16 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
}
+ # According to RFC4627, hex or oct digits are invalid.
+ if($ch eq '0'){
+ my $peek = substr($text,$at,1);
+ if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ }
+ $n .= $ch;
+ next_chr;
+ }
+
while(defined $ch and $ch =~ /\d/){
$n .= $ch;
next_chr;
@@ -61627,6 +63427,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
if(defined $ch and $ch eq '.'){
$n .= '.';
+ $is_dec = 1;
next_chr;
if (!defined $ch or $ch !~ /\d/) {
@@ -61643,6 +63444,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
$n .= $ch;
+ $is_exp = 1;
next_chr;
if(defined($ch) and ($ch eq '+' or $ch eq '-')){
@@ -61668,21 +63470,24 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$v .= $n;
- if ($v !~ /[.eE]/ and length $v > $max_intsize) {
- if ($allow_bigint) { # from Adam Sussman
- require Math::BigInt;
- return Math::BigInt->new($v);
+ if ($is_dec or $is_exp) {
+ if ($allow_bignum) {
+ require Math::BigFloat;
+ return Math::BigFloat->new($v);
}
- else {
- return "$v";
+ } else {
+ if (length $v > $max_intsize) {
+ if ($allow_bignum) { # from Adam Sussman
+ require Math::BigInt;
+ return Math::BigInt->new($v);
+ }
+ else {
+ return "$v";
+ }
}
}
- elsif ($allow_bigint) {
- require Math::BigFloat;
- return Math::BigFloat->new($v);
- }
- return 0+$v;
+ return $is_dec ? $v/1.0 : 0+$v;
}
@@ -61718,11 +63523,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $no_rep = shift;
my $str = defined $text ? substr($text, $at) : '';
my $mess = '';
- my $type = $] >= 5.008 ? 'U*'
- : $] < 5.006 ? 'C*'
- : utf8::is_utf8( $str ) ? 'U*' # 5.6
- : 'C*'
- ;
+ my $type = 'U*';
+
+ if ( OLD_PERL ) {
+ my $type = $] < 5.006 ? 'C*'
+ : utf8::is_utf8( $str ) ? 'U*' # 5.6
+ : 'C*'
+ ;
+ }
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
$mess .= $c == 0x07 ? '\a'
@@ -61813,26 +63621,26 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
*utf8::is_utf8 = *Encode::is_utf8;
}
- if ( $] >= 5.008 ) {
+ if ( !OLD_PERL ) {
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
- }
- if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
- package JSON::PP;
- require subs;
- subs->import('join');
- eval q|
- sub join {
- return '' if (@_ < 2);
- my $j = shift;
- my $str = shift;
- for (@_) { $str .= $j . $_; }
- return $str;
- }
- |;
+ if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
+ package JSON::PP;
+ require subs;
+ subs->import('join');
+ eval q|
+ sub join {
+ return '' if (@_ < 2);
+ my $j = shift;
+ my $str = shift;
+ for (@_) { $str .= $j . $_; }
+ return $str;
+ }
+ |;
+ }
}
@@ -61855,8 +63663,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub JSON::PP::incr_text : lvalue {
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
- if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ if ( $_[0]->{_incr_parser}->{incr_pos} ) {
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
@@ -61876,13 +63684,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
*JSON::PP::reftype = \&Scalar::Util::reftype;
*JSON::PP::refaddr = \&Scalar::Util::refaddr;
}
- else{ # This code is from Sclar::Util.
+ else{ # This code is from Scalar::Util.
# warn $@;
eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
*JSON::PP::blessed = sub {
local($@, $SIG{__DIE__}, $SIG{__WARN__});
ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
};
+ require B;
my %tmap = qw(
B::NULL SCALAR
B::HV HASH
@@ -61925,7 +63734,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
- # shamely copied and modified from JSON::XS code.
+ # shamelessly copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
@@ -61938,18 +63747,6 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
###############################
- package JSON::PP::Boolean;
-
- use overload (
- "0+" => sub { ${$_[0]} },
- "++" => sub { $_[0] = ${$_[0]} + 1 },
- "--" => sub { $_[0] = ${$_[0]} - 1 },
- fallback => 1,
- );
-
-
- ###############################
-
package JSON::PP::IncrParser;
use strict;
@@ -61963,16 +63760,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$JSON::PP::IncrParser::VERSION = '1.01';
- my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
-
sub new {
my ( $class ) = @_;
bless {
incr_nest => 0,
incr_text => undef,
- incr_parsing => 0,
- incr_p => 0,
+ incr_pos => 0,
+ incr_mode => 0,
}, $class;
}
@@ -61990,123 +63785,151 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$self->{incr_text} .= $text;
}
-
- my $max_size = $coder->get_max_size;
-
if ( defined wantarray ) {
-
- $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
-
- if ( wantarray ) {
- my @ret;
-
- $self->{incr_parsing} = 1;
-
+ my $max_size = $coder->get_max_size;
+ my $p = $self->{incr_pos};
+ my @ret;
+ {
do {
- push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
+ unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
+ $self->_incr_parse( $coder );
- unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
- $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
+ if ( $max_size and $self->{incr_pos} > $max_size ) {
+ Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
+ }
+ unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
+ # as an optimisation, do not accumulate white space in the incr buffer
+ if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
+ $self->{incr_pos} = 0;
+ $self->{incr_text} = '';
+ }
+ last;
+ }
}
- } until ( length $self->{incr_text} >= $self->{incr_p} );
-
- $self->{incr_parsing} = 0;
+ my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
+ push @ret, $obj;
+ use bytes;
+ $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
+ $self->{incr_pos} = 0;
+ $self->{incr_nest} = 0;
+ $self->{incr_mode} = 0;
+ last unless wantarray;
+ } while ( wantarray );
+ }
+ if ( wantarray ) {
return @ret;
}
else { # in scalar context
- $self->{incr_parsing} = 1;
- my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
- $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
- return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
+ return $ret[0] ? $ret[0] : undef;
}
-
}
-
}
sub _incr_parse {
- my ( $self, $coder, $text, $skip ) = @_;
- my $p = $self->{incr_p};
- my $restore = $p;
-
- my @obj;
+ my ($self, $coder) = @_;
+ my $text = $self->{incr_text};
my $len = length $text;
+ my $p = $self->{incr_pos};
- if ( $self->{incr_mode} == INCR_M_WS ) {
- while ( $len > $p ) {
- my $s = substr( $text, $p, 1 );
- $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
- $self->{incr_mode} = INCR_M_JSON;
- last;
- }
- }
-
+ INCR_PARSE:
while ( $len > $p ) {
- my $s = substr( $text, $p++, 1 );
-
- if ( $s eq '"' ) {
- if (substr( $text, $p - 2, 1 ) eq '\\' ) {
- next;
- }
-
- if ( $self->{incr_mode} != INCR_M_STR ) {
- $self->{incr_mode} = INCR_M_STR;
+ my $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ my $mode = $self->{incr_mode};
+
+ if ( $mode == INCR_M_WS ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( ord($s) > 0x20 ) {
+ if ( $s eq '#' ) {
+ $self->{incr_mode} = INCR_M_C0;
+ redo INCR_PARSE;
+ } else {
+ $self->{incr_mode} = INCR_M_JSON;
+ redo INCR_PARSE;
+ }
+ }
+ $p++;
}
- else {
- $self->{incr_mode} = INCR_M_JSON;
- unless ( $self->{incr_nest} ) {
+ } elsif ( $mode == INCR_M_BS ) {
+ $p++;
+ $self->{incr_mode} = INCR_M_STR;
+ redo INCR_PARSE;
+ } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( $s eq "\n" ) {
+ $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
last;
}
+ $p++;
}
- }
-
- if ( $self->{incr_mode} == INCR_M_JSON ) {
-
- if ( $s eq '[' or $s eq '{' ) {
- if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
- Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
+ next;
+ } elsif ( $mode == INCR_M_STR ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( $s eq '"' ) {
+ $p++;
+ $self->{incr_mode} = INCR_M_JSON;
+
+ last INCR_PARSE unless $self->{incr_nest};
+ redo INCR_PARSE;
}
+ elsif ( $s eq '\\' ) {
+ $p++;
+ if ( !defined substr($text, $p, 1) ) {
+ $self->{incr_mode} = INCR_M_BS;
+ last INCR_PARSE;
+ }
+ }
+ $p++;
}
- elsif ( $s eq ']' or $s eq '}' ) {
- last if ( --$self->{incr_nest} <= 0 );
- }
- elsif ( $s eq '#' ) {
- while ( $len > $p ) {
- last if substr( $text, $p++, 1 ) eq "\n";
+ } elsif ( $mode == INCR_M_JSON ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p++, 1 );
+ if ( $s eq "\x00" ) {
+ $p--;
+ last INCR_PARSE;
+ } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
+ if ( !$self->{incr_nest} ) {
+ $p--; # do not eat the whitespace, let the next round do it
+ last INCR_PARSE;
+ }
+ next;
+ } elsif ( $s eq '"' ) {
+ $self->{incr_mode} = INCR_M_STR;
+ redo INCR_PARSE;
+ } elsif ( $s eq '[' or $s eq '{' ) {
+ if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
+ Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
+ }
+ next;
+ } elsif ( $s eq ']' or $s eq '}' ) {
+ if ( --$self->{incr_nest} <= 0 ) {
+ last INCR_PARSE;
+ }
+ } elsif ( $s eq '#' ) {
+ $self->{incr_mode} = INCR_M_C1;
+ redo INCR_PARSE;
}
}
-
}
-
}
- $self->{incr_p} = $p;
-
- return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
- return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
-
- return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
-
- local $Carp::CarpLevel = 2;
-
- $self->{incr_p} = $restore;
- $self->{incr_c} = $p;
-
- my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
-
- $self->{incr_text} = substr( $self->{incr_text}, $p );
- $self->{incr_p} = 0;
-
- return $obj || '';
+ $self->{incr_pos} = $p;
+ $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
}
sub incr_text {
- if ( $_[0]->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ if ( $_[0]->{incr_pos} ) {
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{incr_text};
}
@@ -62114,18 +63937,19 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub incr_skip {
my $self = shift;
- $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
- $self->{incr_p} = 0;
+ $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
+ $self->{incr_pos} = 0;
+ $self->{incr_mode} = 0;
+ $self->{incr_nest} = 0;
}
sub incr_reset {
my $self = shift;
$self->{incr_text} = undef;
- $self->{incr_p} = 0;
+ $self->{incr_pos} = 0;
$self->{incr_mode} = 0;
$self->{incr_nest} = 0;
- $self->{incr_parsing} = 0;
}
###############################
@@ -62151,13 +63975,11 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
# OO-interface
- $coder = JSON::PP->new->ascii->pretty->allow_nonref;
+ $json = JSON::PP->new->ascii->pretty->allow_nonref;
- $json_text = $json->encode( $perl_scalar );
+ $pretty_printed_json_text = $json->encode( $perl_scalar );
$perl_scalar = $json->decode( $json_text );
- $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
-
# Note that JSON version 2.0 and above will automatically use
# JSON::XS or JSON::PP, so you should be able to just:
@@ -62166,81 +63988,61 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head1 VERSION
- 2.27202
-
- L<JSON::XS> 2.27 (~2.30) compatible.
-
- =head1 NOTE
-
- JSON::PP had been inculded in JSON distribution (CPAN module).
- It was a perl core module in Perl 5.14.
+ 2.91_04
=head1 DESCRIPTION
- This module is L<JSON::XS> compatible pure Perl module.
- (Perl 5.8 or later is recommended)
-
- JSON::XS is the fastest and most proper JSON module on CPAN.
- It is written by Marc Lehmann in C, so must be compiled and
- installed in the used environment.
-
- JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
-
-
- =head2 FEATURES
-
- =over
-
- =item * correct unicode handling
-
- This module knows how to handle Unicode (depending on Perl version).
-
- See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
-
-
- =item * round-trip integrity
-
- When you serialise a perl data structure using only data types supported
- by JSON and Perl, the deserialised data structure is identical on the Perl
- level. (e.g. the string "2.0" doesn't suddenly become "2" just because
- it looks like a number). There I<are> minor exceptions to this, read the
- MAPPING section below to learn about those.
-
-
- =item * strict checking of JSON correctness
-
- There is no guessing, no generating of illegal JSON texts by default,
- and only JSON is accepted as input by default (the latter is a security feature).
- But when some options are set, loose chcking features are available.
-
- =back
+ JSON::PP is a pure perl JSON decoder/encoder (as of RFC4627, which
+ we know is obsolete but we still stick to; see below for an option
+ to support part of RFC7159), and (almost) compatible to much
+ faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
+ a fallback module when you use L<JSON> module without having
+ installed JSON::XS.
+
+ Because of this fallback feature of JSON.pm, JSON::PP tries not to
+ be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
+ characters such as U+2028 and U+2029 nor support RFC7159/ECMA-404),
+ in order for you not to lose such JavaScript-friendliness silently
+ when you use JSON.pm and install JSON::XS for speed or by accident.
+ If you need JavaScript-friendly RFC7159-compliant pure perl module,
+ try L<JSON::Tiny>, which is derived from L<Mojolicious> web
+ framework and is also smaller and faster than JSON::PP.
+
+ JSON::PP has been in the Perl core since Perl 5.14, mainly for
+ CPAN toolchain modules to parse META.json.
=head1 FUNCTIONAL INTERFACE
- Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
+ This section is taken from JSON::XS almost verbatim. C<encode_json>
+ and C<decode_json> are exported by default.
=head2 encode_json
$json_text = encode_json $perl_scalar
- Converts the given Perl data structure to a UTF-8 encoded, binary string.
+ Converts the given Perl data structure to a UTF-8 encoded, binary string
+ (that is, the string contains octets only). Croaks on error.
This function call is functionally identical to:
$json_text = JSON::PP->new->utf8->encode($perl_scalar)
+ Except being faster.
+
=head2 decode_json
$perl_scalar = decode_json $json_text
The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference.
+ reference. Croaks on error.
This function call is functionally identical to:
$perl_scalar = JSON::PP->new->utf8->decode($json_text)
+ Except being faster.
+
=head2 JSON::PP::is_bool
$is_boolean = JSON::PP::is_bool($scalar)
@@ -62249,114 +64051,24 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
- =head2 JSON::PP::true
-
- Returns JSON true value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::false
-
- Returns JSON false value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::null
-
- Returns C<undef>.
-
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
+ =head1 OBJECT-ORIENTED INTERFACE
- =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
-
- This section supposes that your perl vresion is 5.8 or later.
-
- If you know a JSON text from an outer world - a network, a file content, and so on,
- is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
- with C<utf8> enable. And the decoded result will contain UNICODE characters.
-
- # from network
- my $json = JSON::PP->new->utf8;
- my $json_text = CGI->new->param( 'json_data' );
- my $perl_scalar = $json->decode( $json_text );
-
- # from file content
- local $/;
- open( my $fh, '<', 'json.data' );
- $json_text = <$fh>;
- $perl_scalar = decode_json( $json_text );
-
- If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
-
- use Encode;
- local $/;
- open( my $fh, '<', 'json.data' );
- my $encoding = 'cp932';
- my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
-
- # or you can write the below code.
- #
- # open( my $fh, "<:encoding($encoding)", 'json.data' );
- # $unicode_json_text = <$fh>;
-
- In this case, C<$unicode_json_text> is of course UNICODE string.
- So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable.
-
- $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
-
- Or C<encode 'utf8'> and C<decode_json>:
-
- $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
- # this way is not efficient.
-
- And now, you want to convert your C<$perl_scalar> into JSON data and
- send it to an outer world - a network or a file content, and so on.
-
- Your data usually contains UNICODE strings and you want the converted data to be encoded
- in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
-
- print encode_json( $perl_scalar ); # to a network? file? or display?
- # or
- print $json->utf8->encode( $perl_scalar );
-
- If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
- for some reason, then its characters are regarded as B<latin1> for perl
- (because it does not concern with your $encoding).
- You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable.
- Note that the resulted text is a UNICODE string but no problem to print it.
-
- # $perl_scalar contains $encoding encoded string values
- $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
- # $unicode_json_text consists of characters less than 0x100
- print $unicode_json_text;
-
- Or C<decode $encoding> all string values and C<encode_json>:
-
- $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
- # ... do it to each string values, then encode_json
- $json_text = encode_json( $perl_scalar );
-
- This method is a proper way but probably not efficient.
-
- See to L<Encode>, L<perluniintro>.
-
-
- =head1 METHODS
+ This section is also taken from JSON::XS.
- Basically, check to L<JSON> or L<JSON::XS>.
+ The object oriented interface lets you configure your own encoding or
+ decoding style, within the limits of supported formats.
=head2 new
$json = JSON::PP->new
- Rturns a new JSON::PP object that can be used to de/encode JSON
- strings.
-
- All boolean flags described below are by default I<disabled>.
+ Creates a new JSON::PP object that can be used to de/encode JSON
+ strings. All boolean flags described below are by default I<disabled>.
- The mutators for flags all return the JSON object again and thus calls can
+ The mutators for flags all return the JSON::PP object again and thus calls can
be chained:
my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
@@ -62368,16 +64080,23 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_ascii
- If $enable is true (or missing), then the encode method will not generate characters outside
- the code range 0..127. Any Unicode characters outside that range will be escaped using either
- a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
- (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
+ If C<$enable> is true (or missing), then the C<encode> method will not
+ generate characters outside the code range C<0..127> (which is ASCII). Any
+ Unicode characters outside that range will be escaped using either a
+ single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
+ as per RFC4627. The resulting encoded JSON text can be treated as a native
+ Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
+ or any other superset of ASCII.
- In Perl 5.005, there is no character having high value (more than 255).
- See to L<UNICODE HANDLING ON PERLS>.
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags. This results
+ in a faster and more compact format.
+
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
- If $enable is false, then the encode method will not escape Unicode characters unless
- required by the JSON syntax or other flags. This results in a faster and more compact format.
+ The main use for this flag is to produce JSON texts that can be
+ transmitted over a 7-bit channel, as the encoded JSON texts will not
+ contain any 8 bit characters.
JSON::PP->new->ascii(1)->encode([chr 0x10401])
=> ["\ud801\udc01"]
@@ -62388,16 +64107,28 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_latin1
- If $enable is true (or missing), then the encode method will encode the resulting JSON
- text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
+ outside the code range C<0..255>. The resulting string can be treated as a
+ latin1-encoded JSON text or a native Unicode string. The C<decode> method
+ will not be affected in any way by this flag, as C<decode> by default
+ expects Unicode, which is a strict superset of latin1.
- If $enable is false, then the encode method will not escape Unicode characters
- unless required by the JSON syntax or other flags.
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags.
- JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
- See to L<UNICODE HANDLING ON PERLS>.
+ The main use for this flag is efficiently encoding binary data as JSON
+ text, as most octets will not be escaped, resulting in a smaller encoded
+ size. The disadvantage is that the resulting JSON text is encoded
+ in latin1 (and must correctly be treated as such when storing and
+ transferring), a rare encoding for JSON. It is therefore most useful when
+ you want to store data structures known to contain binary data efficiently
+ in files or databases, not when talking to other JSON encoders/decoders.
+
+ JSON::PP->new->latin1->encode (["\x{89}\x{abc}"]
+ => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
=head2 utf8
@@ -62405,20 +64136,20 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_utf8
- If $enable is true (or missing), then the encode method will encode the JSON result
- into UTF-8, as required by many protocols, while the decode method expects to be handled
- an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
- characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
-
- (In Perl 5.005, any character outside the range 0..255 does not exist.
- See to L<UNICODE HANDLING ON PERLS>.)
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the JSON result into UTF-8, as required by many protocols, while the
+ C<decode> method expects to be handled an UTF-8-encoded string. Please
+ note that UTF-8-encoded strings do not contain any characters outside the
+ range C<0..255>, they are thus useful for bytewise/binary I/O. In future
+ versions, enabling this option might enable autodetection of the UTF-16
+ and UTF-32 encoding families, as described in RFC4627.
- In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
- encoding families, as described in RFC4627.
+ If C<$enable> is false, then the C<encode> method will return the JSON
+ string as a (non-encoded) Unicode string, while C<decode> expects thus a
+ Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
+ to be done yourself, e.g. using the Encode module.
- If $enable is false, then the encode method will return the JSON string as a (non-encoded)
- Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
- (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
Example, output UTF-16BE-encoded JSON:
@@ -62430,18 +64161,13 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use Encode;
$object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
-
=head2 pretty
$json = $json->pretty([$enable])
This enables (or disables) all of the C<indent>, C<space_before> and
- C<space_after> flags in one call to generate the most readable
- (or most compact) form possible.
-
- Equivalent to:
-
- $json->indent->space_before->space_after
+ C<space_after> (and in the future possibly more) flags in one call to
+ generate the most readable (or most compact) form possible.
=head2 indent
@@ -62449,6 +64175,15 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_indent
+ If C<$enable> is true (or missing), then the C<encode> method will use a multiline
+ format as output, putting every array member or object/hash key-value pair
+ into its own line, indenting them properly.
+
+ If C<$enable> is false, no newlines or indenting will be produced, and the
+ resulting JSON text is guaranteed not to contain any C<newlines>.
+
+ This setting has no effect when decoding JSON texts.
+
The default indent space length is three.
You can use C<indent_length> to change the length.
@@ -62464,7 +64199,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
- This setting has no effect when decoding JSON texts.
+ This setting has no effect when decoding JSON texts. You will also
+ most likely combine this setting with C<space_after>.
Example, space_before enabled, space_after and indent disabled:
@@ -62537,6 +64273,28 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
# neither this one...
]
+ =item * C-style multiple-line '/* */'-comments (JSON::PP only)
+
+ Whenever JSON allows whitespace, C-style multiple-line comments are additionally
+ allowed. Everything between C</*> and C<*/> is a comment, after which
+ more white-space and comments are allowed.
+
+ [
+ 1, /* this comment not allowed in JSON */
+ /* neither this one... */
+ ]
+
+ =item * C++-style one-line '//'-comments (JSON::PP only)
+
+ Whenever JSON allows whitespace, C++-style one-line comments are additionally
+ allowed. They are terminated by the first carriage-return or line-feed
+ character, after which more white-space and comments are allowed.
+
+ [
+ 1, // this comment not allowed in JSON
+ // neither this one...
+ ]
+
=back
=head2 canonical
@@ -62550,7 +64308,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
- of the same script).
+ of the same script, and can change even within the same run from 5.18
+ onwards).
This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
@@ -62559,8 +64318,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
This setting has no effect when decoding JSON texts.
- If you want your own sorting routine, you can give a code referece
- or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
+ This setting has currently no effect on tied hashes.
=head2 allow_nonref
@@ -62578,6 +64336,9 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
+ Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
+ resulting in an invalid JSON text:
+
JSON::PP->new->allow_nonref->encode ("Hello, World!")
=> "Hello, World!"
@@ -62587,18 +64348,17 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_allow_unknown
- If $enable is true (or missing), then "encode" will *not* throw an
+ If C<$enable> is true (or missing), then C<encode> will I<not> throw an
exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON "null" value.
- Note that blessed objects are not included here and are handled
- separately by c<allow_nonref>.
+ example, filehandles) but instead will encode a JSON C<null> value. Note
+ that blessed objects are not included here and are handled separately by
+ c<allow_blessed>.
- If $enable is false (the default), then "encode" will throw an
+ If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters anything it cannot encode as JSON.
- This option does not affect "decode" in any way, and it is
- recommended to leave it off unless you know your communications
- partner.
+ This option does not affect C<decode> in any way, and it is recommended to
+ leave it off unless you know your communications partner.
=head2 allow_blessed
@@ -62606,15 +64366,17 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_allow_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference. Instead, the value of the
- B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
- disabled or no C<TO_JSON> method found) or a representation of the
- object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
- encoded. Has no effect on C<decode>.
+ barf when it encounters a blessed reference that it cannot convert
+ otherwise. Instead, a JSON C<null> value is encoded instead of the object.
If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object.
+ exception when it encounters a blessed object that it cannot convert
+ otherwise.
+
+ This setting has no effect on C<decode>.
=head2 convert_blessed
@@ -62622,38 +64384,38 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_convert_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
- on the object's class. If found, it will be called in scalar context
- and the resulting scalar will be encoded instead of the object. If no
- C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
- to do.
+ on the object's class. If found, it will be called in scalar context and
+ the resulting scalar will be encoded instead of the object.
The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
- usually in upper case letters and to avoid collisions with the C<to_json>
+ usually in upper case letters and to avoid collisions with any C<to_json>
function or method.
- This setting does not yet influence C<decode> in any way.
+ If C<$enable> is false (the default), then C<encode> will not consider
+ this type of conversion.
- If C<$enable> is false, then the C<allow_blessed> setting will decide what
- to do when a blessed object is found.
+ This setting has no effect on C<decode>.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument passed to the coderef
- is a reference to the newly-created hash. If the code references returns
- a single scalar (which need not be a reference), this value
- (i.e. a copy of that scalar to avoid aliasing) is inserted into the
- deserialised data structure. If it returns an empty list
- (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
- hash will be inserted. This setting can slow down decoding considerably.
+ time it decodes a JSON object. The only argument is a reference to the
+ newly-created hash. If the code references returns a single scalar (which
+ need not be a reference), this value (i.e. a copy of that scalar to avoid
+ aliasing) is inserted into the deserialised data structure. If it returns
+ an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
+ original deserialised hash will be inserted. This setting can slow down
+ decoding considerably.
When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
@@ -62728,15 +64490,13 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_shrink
- In JSON::XS, this flag resizes strings generated by either
- C<encode> or C<decode> to their minimum size possible.
- It will also try to downgrade any strings to octet-form if possible.
+ If C<$enable> is true (or missing), the string returned by C<encode> will
+ be shrunk (i.e. downgraded if possible).
- In JSON::PP, it is noop about resizing strings but tries
- C<utf8::downgrade> to the returned string by C<encode>.
- See to L<utf8>.
+ The actual definition of what shrink does might change in future versions,
+ but it will always try to save space at the expense of time.
- See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
+ If C<$enable> is false, then JSON::PP does nothing.
=head2 max_depth
@@ -62754,13 +64514,13 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
characters without their matching closing parenthesis crossed to reach a
given character in a string.
+ Setting the maximum depth to one disallows any nesting, so that ensures
+ that the object is only a single hash/object or array.
+
If no argument is given, the highest possible setting will be used, which
is rarely useful.
- See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
-
- When a large value (100 or more) was set and it de/encodes a deep nested object/text,
- it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
+ See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 max_size
@@ -62777,18 +64537,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).
- See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
+ See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 encode
$json_text = $json->encode($perl_scalar)
- Converts the given Perl data structure (a simple scalar or a reference
- to a hash or array) to its JSON representation. Simple scalars will be
- converted into JSON string or number sequences, while references to arrays
- become JSON arrays and references to hashes become JSON objects. Undefined
- Perl values (e.g. C<undef>) become JSON C<null> values.
- References to the integers C<0> and C<1> are converted into C<true> and C<false>.
+ Converts the given Perl value or data structure to its JSON
+ representation. Croaks on error.
=head2 decode
@@ -62797,11 +64553,6 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
- JSON numbers and strings become simple Perl scalars. JSON arrays become
- Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
- C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
- C<null> becomes C<undef>.
-
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
@@ -62811,25 +64562,185 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
silently stop parsing there and return the number of characters consumed
so far.
- JSON->new->decode_prefix ("[1] the tail")
- => ([], 3)
+ This is useful if your JSON texts are not delimited by an outer protocol
+ and you need to know where the JSON text ends.
+
+ JSON::PP->new->decode_prefix ("[1] the tail")
+ => ([1], 3)
+
+ =head1 FLAGS FOR JSON::PP ONLY
+
+ The following flags and properties are for JSON::PP only. If you use
+ any of these, you can't make your application run faster by replacing
+ JSON::PP with JSON::XS. If you need these and also speed boost,
+ try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which
+ supports some of these.
+
+ =head2 allow_singlequote
+
+ $json = $json->allow_singlequote([$enable])
+ $enabled = $json->get_allow_singlequote
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain strings that begin and end with
+ single quotation marks. C<encode> will not be affected in anyway.
+ I<Be aware that this option makes you accept invalid JSON texts
+ as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->allow_singlequote->decode(qq|{"foo":'bar'}|);
+ $json->allow_singlequote->decode(qq|{'foo':"bar"}|);
+ $json->allow_singlequote->decode(qq|{'foo':'bar'}|);
+
+ =head2 allow_barekey
+
+ $json = $json->allow_barekey([$enable])
+ $enabled = $json->get_allow_barekey
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain JSON objects whose names don't
+ begin and end with quotation marks. C<encode> will not be affected
+ in anyway. I<Be aware that this option makes you accept invalid JSON
+ texts as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->allow_barekey->decode(qq|{foo:"bar"}|);
+
+ =head2 allow_bignum
+
+ $json = $json->allow_bignum([$enable])
+ $enabled = $json->get_allow_bignum
+
+ If C<$enable> is true (or missing), then C<decode> will convert
+ big integers Perl cannot handle as integer into L<Math::BigInt>
+ objects and convert floating numbers into L<Math::BigFloat>
+ objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat>
+ objects into JSON numbers.
+
+ $json->allow_nonref->allow_bignum;
+ $bigfloat = $json->decode('2.000000000000000000000000001');
+ print $json->encode($bigfloat);
+ # => 2.000000000000000000000000001
+
+ See also L<MAPPING>.
+
+ =head2 loose
+
+ $json = $json->loose([$enable])
+ $enabled = $json->get_loose
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
+ characters. C<encode> will not be affected in anyway.
+ I<Be aware that this option makes you accept invalid JSON texts
+ as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->loose->decode(qq|["abc
+ def"]|);
+
+ =head2 escape_slash
+
+ $json = $json->escape_slash([$enable])
+ $enabled = $json->get_escape_slash
+
+ If C<$enable> is true (or missing), then C<encode> will explicitly
+ escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of
+ XSS (cross site scripting) that may be caused by C<< </script> >>
+ in a JSON text, with the cost of bloating the size of JSON texts.
+
+ This option may be useful when you embed JSON in HTML, but embedding
+ arbitrary JSON in HTML (by some HTML template toolkit or by string
+ interpolation) is risky in general. You must escape necessary
+ characters in correct order, depending on the context.
+
+ C<decode> will not be affected in anyway.
+
+ =head2 indent_length
+
+ $json = $json->indent_length($number_of_spaces)
+ $length = $json->get_indent_length
+
+ This option is only useful when you also enable C<indent> or C<pretty>.
+
+ JSON::XS indents with three spaces when you C<encode> (if requested
+ by C<indent> or C<pretty>), and the number cannot be changed.
+ JSON::PP allows you to change/get the number of indent spaces with these
+ mutator/accessor. The default number of spaces is three (the same as
+ JSON::XS), and the acceptable range is from C<0> (no indentation;
+ it'd be better to disable indentation by C<indent(0)>) to C<15>.
+
+ =head2 sort_by
+
+ $json = $json->sort_by($code_ref)
+ $json = $json->sort_by($subroutine_name)
+
+ If you just want to sort keys (names) in JSON objects when you
+ C<encode>, enable C<canonical> option (see above) that allows you to
+ sort object keys alphabetically.
+
+ If you do need to sort non-alphabetically for whatever reasons,
+ you can give a code reference (or a subroutine name) to C<sort_by>,
+ then the argument will be passed to Perl's C<sort> built-in function.
+
+ As the sorting is done in the JSON::PP scope, you usually need to
+ prepend C<JSON::PP::> to the subroutine name, and the special variables
+ C<$a> and C<$b> used in the subrontine used by C<sort> function.
+
+ Example:
+
+ my %ORDER = (id => 1, class => 2, name => 3);
+ $json->sort_by(sub {
+ ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999)
+ or $JSON::PP::a cmp $JSON::PP::b
+ });
+ print $json->encode([
+ {name => 'CPAN', id => 1, href => 'http://cpan.org'}
+ ]);
+ # [{"id":1,"name":"CPAN","href":"http://cpan.org"}]
+
+ Note that C<sort_by> affects all the plain hashes in the data structure.
+ If you need finer control, C<tie> necessary hashes with a module that
+ implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>).
+ C<canonical> and C<sort_by> don't affect the key order in C<tie>d
+ hashes.
+
+ use Hash::Ordered;
+ tie my %hash, 'Hash::Ordered',
+ (name => 'CPAN', id => 1, href => 'http://cpan.org');
+ print $json->encode([\%hash]);
+ # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept
=head1 INCREMENTAL PARSING
- Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
+ This section is also taken from JSON::XS.
- In some cases, there is the need for incremental parsing of JSON texts.
- This module does allow you to parse a JSON stream incrementally.
- It does so by accumulating text until it has a full JSON object, which
- it then can decode. This process is similar to using C<decode_prefix>
- to see if a full JSON object is available, but is much more efficient
- (and can be implemented with a minimum of method calls).
+ In some cases, there is the need for incremental parsing of JSON
+ texts. While this module always has to keep both JSON text and resulting
+ Perl data structure in memory at one time, it does allow you to parse a
+ JSON stream incrementally. It does so by accumulating text until it has
+ a full JSON object, which it then can decode. This process is similar to
+ using C<decode_prefix> to see if a full JSON object is available, but
+ is much more efficient (and can be implemented with a minimum of method
+ calls).
- This module will only attempt to parse the JSON text once it is sure it
+ JSON::PP will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
- early as the full parser, for example, it doesn't detect parenthese
- mismatches. The only thing it guarantees is that it starts decoding as
+ early as the full parser, for example, it doesn't detect mismatched
+ parentheses. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
@@ -62859,20 +64770,21 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
- C<incr_skip> to skip the errornous part). This is the most common way of
+ C<incr_skip> to skip the erroneous part). This is the most common way of
using the method.
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
- otherwise. For this to work, there must be no separators between the JSON
- objects or arrays, instead they must be concatenated back-to-back. If
- an error occurs, an exception will be raised as in the scalar context
- case. Note that in this case, any previously-parsed JSON texts will be
- lost.
+ otherwise. For this to work, there must be no separators (other than
+ whitespace) between the JSON objects or arrays, instead they must be
+ concatenated back-to-back. If an error occurs, an exception will be
+ raised as in the scalar context case. Note that in this case, any
+ previously-parsed JSON texts will be lost.
- Example: Parse some JSON arrays/objects in a given string and return them.
+ Example: Parse some JSON arrays/objects in a given string and return
+ them.
- my @objs = JSON->new->incr_parse ("[5][7][1,2]");
+ my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]");
=head2 incr_text
@@ -62886,27 +64798,26 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
real world conditions). As a special exception, you can also call this
method before having parsed anything.
+ That means you can only use this function to look at or manipulate text
+ before or after complete JSON objects, not while the parser is in the
+ middle of parsing a JSON object.
+
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
- $json->incr_text =~ s/\s*,\s*//;
-
- In Perl 5.005, C<lvalue> attribute is not available.
- You must write codes like the below:
-
- $string = $json->incr_text;
- $string =~ s/\s*,\s*//;
- $json->incr_text( $string );
-
=head2 incr_skip
$json->incr_skip
- This will reset the state of the incremental parser and will remove the
- parsed text from the input buffer. This is useful after C<incr_parse>
- died, in which case the input buffer and incremental parser state is left
- unchanged, to skip the text parsed so far and to reset the parse state.
+ This will reset the state of the incremental parser and will remove
+ the parsed text from the input buffer so far. This is useful after
+ C<incr_parse> died, in which case the input buffer and incremental parser
+ state is left unchanged, to skip the text parsed so far and to reset the
+ parse state.
+
+ The difference to C<incr_reset> is that only text until the parse error
+ occurred is removed.
=head2 incr_reset
@@ -62915,152 +64826,22 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.
- This is useful if you want ot repeatedly parse JSON objects and want to
+ This is useful if you want to repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.
- See to L<JSON::XS/INCREMENTAL PARSING> for examples.
-
-
- =head1 JSON::PP OWN METHODS
-
- =head2 allow_singlequote
-
- $json = $json->allow_singlequote([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- JSON strings quoted by single quotations that are invalid JSON
- format.
-
- $json->allow_singlequote->decode({"foo":'bar'});
- $json->allow_singlequote->decode({'foo':"bar"});
- $json->allow_singlequote->decode({'foo':'bar'});
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
-
- =head2 allow_barekey
-
- $json = $json->allow_barekey([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- bare keys of JSON object that are invalid JSON format.
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
- $json->allow_barekey->decode('{foo:"bar"}');
-
- =head2 allow_bignum
-
- $json = $json->allow_bignum([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will convert
- the big integer Perl cannot handle as integer into a L<Math::BigInt>
- object and convert a floating number (any) into a L<Math::BigFloat>.
-
- On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers with C<allow_blessed> enable.
-
- $json->allow_nonref->allow_blessed->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
-
- See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
-
- =head2 loose
-
- $json = $json->loose([$enable])
-
- The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
- and the module doesn't allow to C<decode> to these (except for \x2f).
- If C<$enable> is true (or missing), then C<decode> will accept these
- unescaped strings.
-
- $json->loose->decode(qq|["abc
- def"]|);
-
- See L<JSON::XS/SSECURITY CONSIDERATIONS>.
-
- =head2 escape_slash
-
- $json = $json->escape_slash([$enable])
-
- According to JSON Grammar, I<slash> (U+002F) is escaped. But default
- JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
-
- If C<$enable> is true (or missing), then C<encode> will escape slashes.
-
- =head2 indent_length
-
- $json = $json->indent_length($length)
-
- JSON::XS indent space length is 3 and cannot be changed.
- JSON::PP set the indent space length with the given $length.
- The default is 3. The acceptable range is 0 to 15.
-
- =head2 sort_by
-
- $json = $json->sort_by($function_name)
- $json = $json->sort_by($subroutine_ref)
-
- If $function_name or $subroutine_ref are set, its sort routine are used
- in encoding JSON objects.
-
- $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- $js = $pc->sort_by('own_sort')->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
-
- As the sorting routine runs in the JSON::PP scope, the given
- subroutine name and the special variables C<$a>, C<$b> will begin
- 'JSON::PP::'.
-
- If $integer is set, then the effect is same as C<canonical> on.
-
- =head1 INTERNAL
-
- For developers.
-
- =over
-
- =item PP_encode_box
-
- Returns
-
- {
- depth => $depth,
- indent_count => $indent_count,
- }
-
-
- =item PP_decode_box
-
- Returns
-
- {
- text => $text,
- at => $at,
- ch => $ch,
- len => $len,
- depth => $depth,
- encoding => $encoding,
- is_valid_utf8 => $is_valid_utf8,
- };
-
- =back
-
=head1 MAPPING
- This section is copied from JSON::XS and modified to C<JSON::PP>.
- JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
+ Most of this section is also taken from JSON::XS.
- See to L<JSON::XS/MAPPING>.
+ This section describes how JSON::PP maps Perl values to JSON values and
+ vice versa. These mappings are designed to "do the right thing" in most
+ circumstances automatically, preserving round-tripping characteristics
+ (what you put in comes out as something equivalent).
+
+ For the more enlightened: note that in the following descriptions,
+ lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
+ refers to the abstract Perl language itself.
=head2 JSON -> PERL
@@ -63069,7 +64850,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=item object
A JSON object becomes a reference to a hash in Perl. No ordering of object
- keys is preserved (JSON does not preserver object key ordering itself).
+ keys is preserved (JSON does not preserve object key ordering itself).
=item array
@@ -63089,12 +64870,12 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.
- If the number consists of digits only, C<JSON> will try to represent
+ If the number consists of digits only, JSON::PP will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
which case you lose roundtripping ability, as the JSON number will be
- re-encoded toa JSON string).
+ re-encoded to a JSON string).
Numbers containing a fractional or exponential part will always be
represented as numeric (floating point) values, possibly at a loss of
@@ -63103,36 +64884,30 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
- floating point, C<JSON> only guarantees precision up to but not including
- the leats significant bit.
+ floating point, JSON::PP only guarantees precision up to but not including
+ the least significant bit.
- When C<allow_bignum> is enable, the big integers
- and the numeric can be optionally converted into L<Math::BigInt> and
- L<Math::BigFloat> objects.
+ When C<allow_bignum> is enabled, big integer values and any numeric
+ values will be converted into L<Math::BigInt> and L<Math::BigFloat>
+ objects respectively, without becoming string scalars or losing
+ precision.
=item true, false
These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
- C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
- the C<JSON::is_bool> function.
-
- print JSON::PP::true . "\n";
- => true
- print JSON::PP::true + 1;
- => 1
-
- ok(JSON::true eq '1');
- ok(JSON::true == 1);
-
- C<JSON> will install these missing overloading features to the backend modules.
-
+ C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
+ the C<JSON::PP::is_bool> function.
=item null
A JSON null atom becomes C<undef> in Perl.
- C<JSON::PP::null> returns C<unddef>.
+ =item shell-style comments (C<< # I<text> >>)
+
+ As a nonstandard extension to the JSON syntax that is enabled by the
+ C<relaxed> setting, shell-style comments are allowed. They can start
+ anywhere outside strings and go till the end of the line.
=back
@@ -63147,16 +64922,14 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=item hash references
- Perl hash references become JSON objects. As there is no inherent ordering
- in hash keys (or JSON objects), they will usually be encoded in a
- pseudo-random order that can change between runs of the same program but
- stays generally the same within a single run of a program. C<JSON>
- optionally sort the hash keys (determined by the I<canonical> flag), so
- the same datastructure will serialise to the same JSON text (given same
- settings and version of JSON::XS), but this incurs a runtime overhead
- and is only rarely useful, e.g. when you want to compare some JSON text
- against another for equality.
-
+ Perl hash references become JSON objects. As there is no inherent
+ ordering in hash keys (or JSON objects), they will usually be encoded
+ in a pseudo-random order. JSON::PP can optionally sort the hash keys
+ (determined by the I<canonical> flag and/or I<sort_by> property), so
+ the same data structure will serialise to the same JSON text (given
+ same settings and version of JSON::PP), but this incurs a runtime
+ overhead and is only rarely useful, e.g. when you want to compare some
+ JSON text against another for equality.
=item array references
@@ -63167,31 +64940,30 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
Other unblessed references are generally not allowed and will cause an
exception to be thrown, except for references to the integers C<0> and
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
- also use C<JSON::false> and C<JSON::true> to improve readability.
+ also use C<JSON::PP::false> and C<JSON::PP::true> to improve
+ readability.
- to_json [\0,JSON::PP::true] # yields [false,true]
+ to_json [\0, JSON::PP::true] # yields [false,true]
- =item JSON::PP::true, JSON::PP::false, JSON::PP::null
+ =item JSON::PP::true, JSON::PP::false
These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.
- JSON::PP::null returns C<undef>.
+ =item JSON::PP::null
- =item blessed objects
+ This special value becomes JSON null.
- Blessed objects are not directly representable in JSON. See the
- C<allow_blessed> and C<convert_blessed> methods on various options on
- how to deal with this: basically, you can choose between throwing an
- exception, encoding the reference as if it weren't blessed, or provide
- your own serialiser method.
+ =item blessed objects
- See to L<convert_blessed>.
+ Blessed objects are not directly representable in JSON, but C<JSON::PP>
+ allows various ways of handling objects. See L<OBJECT SERIALISATION>,
+ below, for details.
=item simple scalars
Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
+ difficult objects to encode: JSON::PP will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:
@@ -63213,14 +64985,15 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
"$x"; # stringified
$x .= ""; # another, more awkward way to stringify
print $x; # perl does it for you, too, quite often
+ # (but for older perls)
You can force the type to be a number by numifying it:
my $x = "3"; # some variable containing a string
$x += 0; # numify it, ensuring it will be dumped as a number
- $x *= 1; # same thing, the choise is yours.
+ $x *= 1; # same thing, the choice is yours.
- You can not currently force the type in other, less obscure, ways.
+ You cannot currently force the type in other, less obscure, ways.
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
@@ -63229,94 +65002,171 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.
- =item Big Number
+ JSON::PP (and JSON::XS) trusts what you pass to C<encode> method
+ (or C<encode_json> function) is a clean, validated data structure with
+ values that can be represented as valid JSON values only, because it's
+ not from an external data source (as opposed to JSON texts you pass to
+ C<decode> or C<decode_json>, which JSON::PP considers tainted and
+ doesn't trust). As JSON::PP doesn't know exactly what you and consumers
+ of your JSON texts want the unexpected values to be (you may want to
+ convert them into null, or to stringify them with or without
+ normalisation (string representation of infinities/NaN may vary
+ depending on platforms), or to croak without conversion), you're advised
+ to do what you and your consumers need before you encode, and also not
+ to numify values that may start with values that look like a number
+ (including infinities/NaN), without validating.
- When C<allow_bignum> is enable,
- C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers.
+ =back
+ =head2 OBJECT SERIALISATION
- =back
+ As for Perl objects, JSON::PP only supports a pure JSON representation (without the ability to deserialise the object automatically again).
- =head1 UNICODE HANDLING ON PERLS
+ =head3 SERIALISATION
- If you do not know about Unicode on Perl well,
- please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
+ What happens when C<JSON::PP> encounters a Perl object depends on the
+ C<allow_blessed>, C<convert_blessed> and C<allow_bignum> settings, which are
+ used in this order:
- =head2 Perl 5.8 and later
+ =over 4
- Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
+ =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
- $json->allow_nonref->encode(chr hex 3042);
- $json->allow_nonref->encode(chr hex 12345);
+ In this case, the C<TO_JSON> method of the object is invoked in scalar
+ context. It must return a single scalar that can be directly encoded into
+ JSON. This scalar replaces the object in the JSON text.
- Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
+ For example, the following C<TO_JSON> method will convert all L<URI>
+ objects to JSON strings when serialised. The fact that these values
+ originally were L<URI> objects is lost.
- $json->allow_nonref->decode('"\u3042"');
- $json->allow_nonref->decode('"\ud808\udf45"');
+ sub URI::TO_JSON {
+ my ($uri) = @_;
+ $uri->as_string
+ }
- Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
+ =item 2. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
- Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
- so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
+ The object will be serialised as a JSON number value.
+ =item 3. C<allow_blessed> is enabled.
- =head2 Perl 5.6
+ The object will be serialised as a JSON null value.
- Perl can handle Unicode and the JSON::PP de/encode methods also work.
+ =item 4. none of the above
- =head2 Perl 5.005
+ If none of the settings are enabled or the respective methods are missing,
+ C<JSON::PP> throws an exception.
- Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
- That means the unicode handling is not available.
+ =back
- In encoding,
+ =head1 ENCODING/CODESET FLAG NOTES
- $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
- $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
+ This section is taken from JSON::XS.
- Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
- as C<$value % 256>, so the above codes are equivalent to :
+ The interested reader might have seen a number of flags that signify
+ encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
+ some confusion on what these do, so here is a short comparison:
- $json->allow_nonref->encode(chr 66);
- $json->allow_nonref->encode(chr 69);
+ C<utf8> controls whether the JSON text created by C<encode> (and expected
+ by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
+ control whether C<encode> escapes character values outside their respective
+ codeset range. Neither of these flags conflict with each other, although
+ some combinations make less sense than others.
- In decoding,
+ Care has been taken to make all flags symmetrical with respect to
+ C<encode> and C<decode>, that is, texts encoded with any combination of
+ these flag values will be correctly decoded when the same flags are used
+ - in general, if you use different flag settings while encoding vs. when
+ decoding you likely have a bug somewhere.
- $json->decode('"\u00e3\u0081\u0082"');
+ Below comes a verbose discussion of these flags. Note that a "codeset" is
+ simply an abstract set of character-codepoint pairs, while an encoding
+ takes those codepoint numbers and I<encodes> them, in our case into
+ octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
+ and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
+ the same time, which can be confusing.
- The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
- japanese character (C<HIRAGANA LETTER A>).
- And if it is represented in Unicode code point, C<U+3042>.
+ =over 4
- Next,
+ =item C<utf8> flag disabled
- $json->decode('"\u3042"');
+ When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
+ and expect Unicode strings, that is, characters with high ordinal Unicode
+ values (> 255) will be encoded as such characters, and likewise such
+ characters are decoded as-is, no changes to them will be done, except
+ "(re-)interpreting" them as Unicode codepoints or Unicode characters,
+ respectively (to Perl, these are the same thing in strings unless you do
+ funny/weird/dumb stuff).
- We ordinary expect the returned value is a Unicode character C<U+3042>.
- But here is 5.005 world. This is C<0xE3 0x81 0x82>.
+ This is useful when you want to do the encoding yourself (e.g. when you
+ want to have UTF-16 encoded JSON texts) or when some other layer does
+ the encoding for you (for example, when printing to a terminal using a
+ filehandle that transparently encodes to UTF-8 you certainly do NOT want
+ to UTF-8 encode your data first and have Perl encode it another time).
- $json->decode('"\ud808\udf45"');
+ =item C<utf8> flag enabled
- This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
+ If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
+ characters using the corresponding UTF-8 multi-byte sequence, and will
+ expect your input strings to be encoded as UTF-8, that is, no "character"
+ of the input string must have any value > 255, as UTF-8 does not allow
+ that.
+ The C<utf8> flag therefore switches between two modes: disabled means you
+ will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
+ octet/binary string in Perl.
- =head1 TODO
+ =item C<latin1> or C<ascii> flags enabled
- =over
+ With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
+ with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
+ characters as specified by the C<utf8> flag.
- =item speed
+ If C<utf8> is disabled, then the result is also correctly encoded in those
+ character sets (as both are proper subsets of Unicode, meaning that a
+ Unicode string with all character values < 256 is the same thing as a
+ ISO-8859-1 string, and a Unicode string with all character values < 128 is
+ the same thing as an ASCII string in Perl).
- =item memory saving
+ If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
+ regardless of these flags, just some more characters will be escaped using
+ C<\uXXXX> then before.
- =back
+ Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
+ encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
+ encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
+ a subset of Unicode), while ASCII is.
+
+ Surprisingly, C<decode> will ignore these flags and so treat all input
+ values as governed by the C<utf8> flag. If it is disabled, this allows you
+ to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
+ Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
+
+ So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
+ they only govern when the JSON output engine escapes a character or not.
+
+ The main use for C<latin1> is to relatively efficiently store binary data
+ as JSON, at the expense of breaking compatibility with most JSON decoders.
+
+ The main use for C<ascii> is to force the output to not contain characters
+ with values > 127, which means you can interpret the resulting string
+ as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
+ 8-bit-encoding, and still get the same data structure back. This is useful
+ when your channel for JSON transfer is not 8-bit clean or the encoding
+ might be mangled in between (e.g. in mail), and works because ASCII is a
+ proper subset of most 8-bit and multibyte encodings in use in the world.
+ =back
=head1 SEE ALSO
- Most of the document are copied and modified from JSON::XS doc.
+ The F<json_pp> command line utility for quick experiments.
- L<JSON::XS>
+ L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives.
+ L<JSON> and L<JSON::MaybeXS> for easy migration.
+
+ L<JSON::PP::Compat5005> and L<JSON::PP::Compat5006> for older perl users.
RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
@@ -63327,7 +65177,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head1 COPYRIGHT AND LICENSE
- Copyright 2007-2013 by Makamaka Hannyaharamitu
+ Copyright 2007-2016 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
@@ -63336,6 +65186,22 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
+ package JSON::PP::Boolean;
+
+ use strict;
+ use overload (
+ "0+" => sub { ${$_[0]} },
+ "++" => sub { $_[0] = ${$_[0]} + 1 },
+ "--" => sub { $_[0] = ${$_[0]} - 1 },
+ fallback => 1,
+ );
+
+ $JSON::PP::Boolean::VERSION = '2.94';
+
+ 1;
+
+ __END__
+
=head1 NAME
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
@@ -63349,13 +65215,6 @@ $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
This module exists only to provide overload resolution for Storable and similar modules. See
L<JSON::PP> for more info about this class.
- =cut
-
- use JSON::PP ();
- use strict;
-
- 1;
-
=head1 AUTHOR
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
@@ -63372,15 +65231,17 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use 5.005;
use strict;
- use base qw(Exporter);
+
+ use Exporter ();
+ BEGIN { @JSON::backportPP::ISA = ('Exporter') }
+
use overload ();
+ use JSON::backportPP::Boolean;
use Carp ();
- use B ();
#use Devel::Peek;
- use vars qw($VERSION);
- $VERSION = '2.27204';
+ $JSON::backportPP::VERSION = '2.94';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -63410,6 +65271,13 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use constant P_ALLOW_UNKNOWN => 18;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
+ use constant USE_B => 0;
+
+ BEGIN {
+ if (USE_B) {
+ require B;
+ }
+ }
BEGIN {
my @xs_compati_bit_properties = qw(
@@ -63421,33 +65289,33 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
allow_barekey escape_slash as_nonblessed
);
- # Perl version check, Unicode handling is enable?
+ # Perl version check, Unicode handling is enabled?
# Helper module sets @JSON::PP::_properties.
- if ($] < 5.008 ) {
+ if ( OLD_PERL ) {
my $helper = $] >= 5.006 ? 'JSON::backportPP::Compat5006' : 'JSON::backportPP::Compat5005';
eval qq| require $helper |;
if ($@) { Carp::croak $@; }
}
for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
- my $flag_name = 'P_' . uc($name);
+ my $property_id = 'P_' . uc($name);
eval qq/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
if (\$enable) {
- \$_[0]->{PROPS}->[$flag_name] = 1;
+ \$_[0]->{PROPS}->[$property_id] = 1;
}
else {
- \$_[0]->{PROPS}->[$flag_name] = 0;
+ \$_[0]->{PROPS}->[$property_id] = 0;
}
\$_[0];
}
sub get_$name {
- \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
+ \$_[0]->{PROPS}->[$property_id] ? 1 : '';
}
/;
}
@@ -63458,16 +65326,6 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# Functions
- my %encode_allow_method
- = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
- allow_blessed convert_blessed indent indent_length allow_bignum
- as_nonblessed
- /;
- my %decode_allow_method
- = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
- allow_barekey max_size relaxed/;
-
-
my $JSON; # cache
sub encode_json ($) { # encode
@@ -63498,9 +65356,6 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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,
};
@@ -63533,7 +65388,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $enable = defined $v ? $v : 1;
if ($enable) { # indent_length(3) for JSON::XS compatibility
- $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
+ $self->indent(1)->space_before(1)->space_after(1);
}
else {
$self->indent(0)->space_before(0)->space_after(0);
@@ -63565,14 +65420,24 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub filter_json_object {
- $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
+ if (defined $_[1] and ref $_[1] eq 'CODE') {
+ $_[0]->{cb_object} = $_[1];
+ } else {
+ delete $_[0]->{cb_object};
+ }
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub filter_json_single_key_object {
- if (@_ > 1) {
+ if (@_ == 1 or @_ > 3) {
+ Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
+ }
+ if (defined $_[2] and ref $_[2] eq 'CODE') {
$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
+ } else {
+ delete $_[0]->{cb_sk_object}->{$_[1]};
+ delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
}
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
@@ -63598,7 +65463,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
sub allow_bigint {
- Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
+ Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
+ $_[0]->allow_bignum;
}
###############################
@@ -63638,11 +65504,11 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$indent_count = 0;
$depth = 0;
- my $idx = $self->{PROPS};
+ my $props = $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,
+ = @{$props}[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/};
@@ -63656,7 +65522,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
- if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
+ if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
my $str = $self->object_to_json($obj);
@@ -63666,7 +65532,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
utf8::upgrade($str);
}
- if ($idx->[ P_SHRINK ]) {
+ if ($props->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
@@ -63704,13 +65570,14 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
return "$obj" if ( $bignum and _is_bignum($obj) );
- return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
+ if ($allow_blessed) {
+ return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
+ return 'null';
+ }
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);
@@ -63734,15 +65601,16 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
for my $k ( _sort( $obj ) ) {
if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
- push @res, string_to_json( $self, $k )
+ push @res, $self->string_to_json( $k )
. $del
- . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
+ . ( ref $obj->{$k} ? $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 : '' ) . '}';
+ return '{}' unless @res;
+ return '{' . $pre . join( ",$pre", @res ) . $post . '}';
}
@@ -63756,36 +65624,53 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
for my $v (@$obj){
- push @res, $self->object_to_json($v) || $self->value_to_json($v);
+ push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
}
--$depth;
$self->_down_indent() if ($indent);
- return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
+ return '[]' unless @res;
+ return '[' . $pre . join( ",$pre", @res ) . $post . ']';
}
+ sub _looks_like_number {
+ my $value = shift;
+ if (USE_B) {
+ my $b_obj = B::svref_2object(\$value);
+ my $flags = $b_obj->FLAGS;
+ return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
+ return;
+ } else {
+ no warnings 'numeric';
+ # detect numbers
+ # string & "" -> ""
+ # number & "" -> 0 (with warning)
+ # nan and inf can detect as numbers, so check with * 0
+ return unless length((my $dummy = "") & $value);
+ return unless 0 + $value eq $value;
+ return 1 if $value * 0 == 0;
+ return -1; # inf/nan
+ }
+ }
sub value_to_json {
my ($self, $value) = @_;
return 'null' if(!defined $value);
- my $b_obj = B::svref_2object(\$value); # for round trip problem
- my $flags = $b_obj->FLAGS;
-
- return $value # as is
- if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
-
my $type = ref($value);
- if(!$type){
- return string_to_json($self, $value);
+ if (!$type) {
+ if (_looks_like_number($value)) {
+ return $value;
+ }
+ return $self->string_to_json($value);
}
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
return $$value == 1 ? 'true' : 'false';
}
- elsif ($type) {
+ else {
if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
return $self->value_to_json("$value");
}
@@ -63797,25 +65682,19 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
: encode_error("cannot encode reference to scalar");
}
- if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
- return 'null';
- }
- else {
- if ( $type eq 'SCALAR' or $type eq 'REF' ) {
+ 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 {
+ }
+ 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';
- }
-
}
@@ -63977,7 +65856,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $text; # json data
my $at; # offset
- my $ch; # 1chracter
+ my $ch; # first character
my $len; # text length (changed according to UTF8 or NON UTF8)
# INTERNAL
my $depth; # nest counter
@@ -63994,19 +65873,27 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $F_HOOK;
- my $allow_bigint; # using Math::BigInt
+ my $allow_bignum; # using Math::BigInt/BigFloat
my $singlequote; # loosely quoting
my $loose; #
my $allow_barekey; # bareKey
- # $opt flag
- # 0x00000001 .... decode_prefix
- # 0x10000000 .... incr_parse
+ sub _detect_utf_encoding {
+ my $text = shift;
+ my @octets = unpack('C4', $text);
+ return 'unknown' unless defined $octets[3];
+ return ( $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';
+ }
sub PP_decode_json {
- my ($self, $opt); # $opt is an effective flag during this decode_json.
+ my ($self, $want_offset);
- ($self, $text, $opt) = @_;
+ ($self, $text, $want_offset) = @_;
($at, $ch, $depth) = (0, '', 0);
@@ -64014,16 +65901,23 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
- my $idx = $self->{PROPS};
+ my $props = $self->{PROPS};
- ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
- = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
+ ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote)
+ = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
if ( $utf8 ) {
- utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
+ $encoding = _detect_utf_encoding($text);
+ if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
+ require Encode;
+ Encode::from_to($text, $encoding, 'utf-8');
+ } else {
+ utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
+ }
}
else {
utf8::upgrade( $text );
+ utf8::encode( $text );
}
$len = length $text;
@@ -64040,27 +65934,13 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
) if ($bytes > $max_size);
}
- # Currently no effect
- # should use regexp
- my @octets = unpack('C4', $text);
- $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
- : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
- : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
- : ( $octets[2] ) ? 'UTF-16LE'
- : (!$octets[2] ) ? 'UTF-32LE'
- : 'unknown';
-
white(); # remove head white space
- my $valid_start = defined $ch; # Is there a first character for JSON structure?
+ decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
my $result = value();
- return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
-
- decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
-
- if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
+ if ( !$props->[ 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);
@@ -64072,12 +65952,11 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
white(); # remove tail white space
- if ( $ch ) {
- return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
- decode_error("garbage after JSON object");
- }
+ return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
+
+ decode_error("garbage after JSON object") if defined $ch;
- ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
+ $result;
}
@@ -64098,13 +65977,12 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
sub string {
- my ($i, $s, $t, $u);
my $utf16;
my $is_utf8;
($is_valid_utf8, $utf8_len) = ('', 0);
- $s = ''; # basically UTF8 flag on
+ my $s = ''; # basically UTF8 flag on
if($ch eq '"' or ($singlequote and $ch eq "'")){
my $boundChar = $ch;
@@ -64175,17 +66053,12 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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;
@@ -64209,10 +66082,10 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub white {
while( defined $ch ){
- if($ch le ' '){
+ if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
next_chr();
}
- elsif($ch eq '/'){
+ elsif($relaxed and $ch eq '/'){
next_chr();
if(defined $ch and $ch eq '/'){
1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
@@ -64303,6 +66176,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
}
+ $at-- if defined $ch and $ch ne '';
decode_error(", or ] expected while parsing array");
}
@@ -64369,7 +66243,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
- $at--;
+ $at-- if defined $ch and $ch ne '';
decode_error(", or } expected while parsing object/hash");
}
@@ -64418,32 +66292,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub number {
my $n = '';
my $v;
-
- # According to RFC4627, hex or oct digits are invalid.
- if($ch eq '0'){
- my $peek = substr($text,$at,1);
- my $hex = $peek =~ /[xX]/; # 0 or 1
-
- if($hex){
- decode_error("malformed number (leading zero must not be followed by another digit)");
- ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
- }
- else{ # oct
- ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
- if (defined $n and length $n > 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- }
-
- if(defined $n and length($n)){
- if (!$hex and length($n) == 1) {
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- $at += length($n) + $hex;
- next_chr;
- return $hex ? hex($n) : oct($n);
- }
- }
+ my $is_dec;
+ my $is_exp;
if($ch eq '-'){
$n = '-';
@@ -64453,6 +66303,16 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
}
+ # According to RFC4627, hex or oct digits are invalid.
+ if($ch eq '0'){
+ my $peek = substr($text,$at,1);
+ if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ }
+ $n .= $ch;
+ next_chr;
+ }
+
while(defined $ch and $ch =~ /\d/){
$n .= $ch;
next_chr;
@@ -64460,6 +66320,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if(defined $ch and $ch eq '.'){
$n .= '.';
+ $is_dec = 1;
next_chr;
if (!defined $ch or $ch !~ /\d/) {
@@ -64476,6 +66337,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
$n .= $ch;
+ $is_exp = 1;
next_chr;
if(defined($ch) and ($ch eq '+' or $ch eq '-')){
@@ -64501,21 +66363,24 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$v .= $n;
- if ($v !~ /[.eE]/ and length $v > $max_intsize) {
- if ($allow_bigint) { # from Adam Sussman
- require Math::BigInt;
- return Math::BigInt->new($v);
+ if ($is_dec or $is_exp) {
+ if ($allow_bignum) {
+ require Math::BigFloat;
+ return Math::BigFloat->new($v);
}
- else {
- return "$v";
+ } else {
+ if (length $v > $max_intsize) {
+ if ($allow_bignum) { # from Adam Sussman
+ require Math::BigInt;
+ return Math::BigInt->new($v);
+ }
+ else {
+ return "$v";
+ }
}
}
- elsif ($allow_bigint) {
- require Math::BigFloat;
- return Math::BigFloat->new($v);
- }
- return 0+$v;
+ return $is_dec ? $v/1.0 : 0+$v;
}
@@ -64551,11 +66416,14 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $no_rep = shift;
my $str = defined $text ? substr($text, $at) : '';
my $mess = '';
- my $type = $] >= 5.008 ? 'U*'
- : $] < 5.006 ? 'C*'
- : utf8::is_utf8( $str ) ? 'U*' # 5.6
- : 'C*'
- ;
+ my $type = 'U*';
+
+ if ( OLD_PERL ) {
+ my $type = $] < 5.006 ? 'C*'
+ : utf8::is_utf8( $str ) ? 'U*' # 5.6
+ : 'C*'
+ ;
+ }
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
$mess .= $c == 0x07 ? '\a'
@@ -64646,27 +66514,27 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
*utf8::is_utf8 = *Encode::is_utf8;
}
- if ( $] >= 5.008 ) {
+ if ( !OLD_PERL ) {
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
- }
- if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
- package # hide from PAUSE
- JSON::PP;
- require subs;
- subs->import('join');
- eval q|
- sub join {
- return '' if (@_ < 2);
- my $j = shift;
- my $str = shift;
- for (@_) { $str .= $j . $_; }
- return $str;
- }
- |;
+ if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
+ package # hide from PAUSE
+ JSON::PP;
+ require subs;
+ subs->import('join');
+ eval q|
+ sub join {
+ return '' if (@_ < 2);
+ my $j = shift;
+ my $str = shift;
+ for (@_) { $str .= $j . $_; }
+ return $str;
+ }
+ |;
+ }
}
@@ -64689,8 +66557,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub JSON::PP::incr_text : lvalue {
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
- if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ if ( $_[0]->{_incr_parser}->{incr_pos} ) {
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
@@ -64717,6 +66585,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
local($@, $SIG{__DIE__}, $SIG{__WARN__});
ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
};
+ require B;
my %tmap = qw(
B::NULL SCALAR
B::HV HASH
@@ -64761,20 +66630,6 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# shamelessly copied and modified from JSON::XS code.
- unless ( $INC{'JSON/PP.pm'} ) {
- eval q|
- package
- JSON::PP::Boolean;
-
- use overload (
- "0+" => sub { ${$_[0]} },
- "++" => sub { $_[0] = ${$_[0]} + 1 },
- "--" => sub { $_[0] = ${$_[0]} - 1 },
- fallback => 1,
- );
- |;
- }
-
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
@@ -64786,8 +66641,6 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
###############################
- ###############################
-
package # hide from PAUSE
JSON::PP::IncrParser;
@@ -64800,10 +66653,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use constant INCR_M_C0 => 4;
use constant INCR_M_C1 => 5;
- use vars qw($VERSION);
- $VERSION = '1.01';
-
- my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
+ $JSON::backportPP::IncrParser::VERSION = '1.01';
sub new {
my ( $class ) = @_;
@@ -64811,8 +66661,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
bless {
incr_nest => 0,
incr_text => undef,
- incr_parsing => 0,
- incr_p => 0,
+ incr_pos => 0,
+ incr_mode => 0,
}, $class;
}
@@ -64830,123 +66680,151 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$self->{incr_text} .= $text;
}
-
- my $max_size = $coder->get_max_size;
-
if ( defined wantarray ) {
-
- $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
-
- if ( wantarray ) {
- my @ret;
-
- $self->{incr_parsing} = 1;
-
+ my $max_size = $coder->get_max_size;
+ my $p = $self->{incr_pos};
+ my @ret;
+ {
do {
- push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
+ unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
+ $self->_incr_parse( $coder );
- unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
- $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
+ if ( $max_size and $self->{incr_pos} > $max_size ) {
+ Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
+ }
+ unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
+ # as an optimisation, do not accumulate white space in the incr buffer
+ if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
+ $self->{incr_pos} = 0;
+ $self->{incr_text} = '';
+ }
+ last;
+ }
}
- } until ( length $self->{incr_text} >= $self->{incr_p} );
-
- $self->{incr_parsing} = 0;
+ my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
+ push @ret, $obj;
+ use bytes;
+ $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
+ $self->{incr_pos} = 0;
+ $self->{incr_nest} = 0;
+ $self->{incr_mode} = 0;
+ last unless wantarray;
+ } while ( wantarray );
+ }
+ if ( wantarray ) {
return @ret;
}
else { # in scalar context
- $self->{incr_parsing} = 1;
- my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
- $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
- return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
+ return $ret[0] ? $ret[0] : undef;
}
-
}
-
}
sub _incr_parse {
- my ( $self, $coder, $text, $skip ) = @_;
- my $p = $self->{incr_p};
- my $restore = $p;
-
- my @obj;
+ my ($self, $coder) = @_;
+ my $text = $self->{incr_text};
my $len = length $text;
+ my $p = $self->{incr_pos};
- if ( $self->{incr_mode} == INCR_M_WS ) {
- while ( $len > $p ) {
- my $s = substr( $text, $p, 1 );
- $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
- $self->{incr_mode} = INCR_M_JSON;
- last;
- }
- }
-
+ INCR_PARSE:
while ( $len > $p ) {
- my $s = substr( $text, $p++, 1 );
-
- if ( $s eq '"' ) {
- if (substr( $text, $p - 2, 1 ) eq '\\' ) {
- next;
- }
-
- if ( $self->{incr_mode} != INCR_M_STR ) {
- $self->{incr_mode} = INCR_M_STR;
+ my $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ my $mode = $self->{incr_mode};
+
+ if ( $mode == INCR_M_WS ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( ord($s) > 0x20 ) {
+ if ( $s eq '#' ) {
+ $self->{incr_mode} = INCR_M_C0;
+ redo INCR_PARSE;
+ } else {
+ $self->{incr_mode} = INCR_M_JSON;
+ redo INCR_PARSE;
+ }
+ }
+ $p++;
}
- else {
- $self->{incr_mode} = INCR_M_JSON;
- unless ( $self->{incr_nest} ) {
+ } elsif ( $mode == INCR_M_BS ) {
+ $p++;
+ $self->{incr_mode} = INCR_M_STR;
+ redo INCR_PARSE;
+ } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( $s eq "\n" ) {
+ $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
last;
}
+ $p++;
}
- }
-
- if ( $self->{incr_mode} == INCR_M_JSON ) {
-
- if ( $s eq '[' or $s eq '{' ) {
- if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
- Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
+ next;
+ } elsif ( $mode == INCR_M_STR ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p, 1 );
+ last INCR_PARSE unless defined $s;
+ if ( $s eq '"' ) {
+ $p++;
+ $self->{incr_mode} = INCR_M_JSON;
+
+ last INCR_PARSE unless $self->{incr_nest};
+ redo INCR_PARSE;
}
+ elsif ( $s eq '\\' ) {
+ $p++;
+ if ( !defined substr($text, $p, 1) ) {
+ $self->{incr_mode} = INCR_M_BS;
+ last INCR_PARSE;
+ }
+ }
+ $p++;
}
- elsif ( $s eq ']' or $s eq '}' ) {
- last if ( --$self->{incr_nest} <= 0 );
- }
- elsif ( $s eq '#' ) {
- while ( $len > $p ) {
- last if substr( $text, $p++, 1 ) eq "\n";
+ } elsif ( $mode == INCR_M_JSON ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p++, 1 );
+ if ( $s eq "\x00" ) {
+ $p--;
+ last INCR_PARSE;
+ } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
+ if ( !$self->{incr_nest} ) {
+ $p--; # do not eat the whitespace, let the next round do it
+ last INCR_PARSE;
+ }
+ next;
+ } elsif ( $s eq '"' ) {
+ $self->{incr_mode} = INCR_M_STR;
+ redo INCR_PARSE;
+ } elsif ( $s eq '[' or $s eq '{' ) {
+ if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
+ Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
+ }
+ next;
+ } elsif ( $s eq ']' or $s eq '}' ) {
+ if ( --$self->{incr_nest} <= 0 ) {
+ last INCR_PARSE;
+ }
+ } elsif ( $s eq '#' ) {
+ $self->{incr_mode} = INCR_M_C1;
+ redo INCR_PARSE;
}
}
-
}
-
}
- $self->{incr_p} = $p;
-
- return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
- return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
-
- return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
-
- local $Carp::CarpLevel = 2;
-
- $self->{incr_p} = $restore;
- $self->{incr_c} = $p;
-
- my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
-
- $self->{incr_text} = substr( $self->{incr_text}, $p );
- $self->{incr_p} = 0;
-
- return $obj || '';
+ $self->{incr_pos} = $p;
+ $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
}
sub incr_text {
- if ( $_[0]->{incr_parsing} ) {
- Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+ if ( $_[0]->{incr_pos} ) {
+ Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
}
$_[0]->{incr_text};
}
@@ -64954,18 +66832,19 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub incr_skip {
my $self = shift;
- $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
- $self->{incr_p} = 0;
+ $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
+ $self->{incr_pos} = 0;
+ $self->{incr_mode} = 0;
+ $self->{incr_nest} = 0;
}
sub incr_reset {
my $self = shift;
$self->{incr_text} = undef;
- $self->{incr_p} = 0;
+ $self->{incr_pos} = 0;
$self->{incr_mode} = 0;
$self->{incr_nest} = 0;
- $self->{incr_parsing} = 0;
}
###############################
@@ -64991,13 +66870,11 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# OO-interface
- $coder = JSON::PP->new->ascii->pretty->allow_nonref;
+ $json = JSON::PP->new->ascii->pretty->allow_nonref;
- $json_text = $json->encode( $perl_scalar );
+ $pretty_printed_json_text = $json->encode( $perl_scalar );
$perl_scalar = $json->decode( $json_text );
- $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
-
# Note that JSON version 2.0 and above will automatically use
# JSON::XS or JSON::PP, so you should be able to just:
@@ -65006,79 +66883,61 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=head1 VERSION
- 2.27200
-
- L<JSON::XS> 2.27 (~2.30) compatible.
+ 2.91_04
=head1 DESCRIPTION
- This module is L<JSON::XS> compatible pure Perl module.
- (Perl 5.8 or later is recommended)
-
- JSON::XS is the fastest and most proper JSON module on CPAN.
- It is written by Marc Lehmann in C, so must be compiled and
- installed in the used environment.
-
- JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
-
-
- =head2 FEATURES
-
- =over
-
- =item * correct unicode handling
-
- This module knows how to handle Unicode (depending on Perl version).
-
- See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and
- L<UNICODE HANDLING ON PERLS>.
-
-
- =item * round-trip integrity
-
- When you serialise a perl data structure using only data types
- supported by JSON and Perl, the deserialised data structure is
- identical on the Perl level. (e.g. the string "2.0" doesn't suddenly
- become "2" just because it looks like a number). There I<are> minor
- exceptions to this, read the MAPPING section below to learn about
- those.
-
-
- =item * strict checking of JSON correctness
-
- There is no guessing, no generating of illegal JSON texts by default,
- and only JSON is accepted as input by default (the latter is a
- security feature). But when some options are set, loose checking
- features are available.
-
- =back
+ JSON::PP is a pure perl JSON decoder/encoder (as of RFC4627, which
+ we know is obsolete but we still stick to; see below for an option
+ to support part of RFC7159), and (almost) compatible to much
+ faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
+ a fallback module when you use L<JSON> module without having
+ installed JSON::XS.
+
+ Because of this fallback feature of JSON.pm, JSON::PP tries not to
+ be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
+ characters such as U+2028 and U+2029 nor support RFC7159/ECMA-404),
+ in order for you not to lose such JavaScript-friendliness silently
+ when you use JSON.pm and install JSON::XS for speed or by accident.
+ If you need JavaScript-friendly RFC7159-compliant pure perl module,
+ try L<JSON::Tiny>, which is derived from L<Mojolicious> web
+ framework and is also smaller and faster than JSON::PP.
+
+ JSON::PP has been in the Perl core since Perl 5.14, mainly for
+ CPAN toolchain modules to parse META.json.
=head1 FUNCTIONAL INTERFACE
- Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
+ This section is taken from JSON::XS almost verbatim. C<encode_json>
+ and C<decode_json> are exported by default.
=head2 encode_json
$json_text = encode_json $perl_scalar
- Converts the given Perl data structure to a UTF-8 encoded, binary string.
+ Converts the given Perl data structure to a UTF-8 encoded, binary string
+ (that is, the string contains octets only). Croaks on error.
This function call is functionally identical to:
$json_text = JSON::PP->new->utf8->encode($perl_scalar)
+ Except being faster.
+
=head2 decode_json
$perl_scalar = decode_json $json_text
The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference.
+ reference. Croaks on error.
This function call is functionally identical to:
$perl_scalar = JSON::PP->new->utf8->decode($json_text)
+ Except being faster.
+
=head2 JSON::PP::is_bool
$is_boolean = JSON::PP::is_bool($scalar)
@@ -65087,114 +66946,24 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
- =head2 JSON::PP::true
-
- Returns JSON true value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::false
-
- Returns JSON false value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::null
-
- Returns C<undef>.
-
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
+ =head1 OBJECT-ORIENTED INTERFACE
- =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
-
- This section supposes that your perl version is 5.8 or later.
-
- If you know a JSON text from an outer world - a network, a file content, and so on,
- is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
- with C<utf8> enable. And the decoded result will contain UNICODE characters.
-
- # from network
- my $json = JSON::PP->new->utf8;
- my $json_text = CGI->new->param( 'json_data' );
- my $perl_scalar = $json->decode( $json_text );
-
- # from file content
- local $/;
- open( my $fh, '<', 'json.data' );
- $json_text = <$fh>;
- $perl_scalar = decode_json( $json_text );
-
- If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
-
- use Encode;
- local $/;
- open( my $fh, '<', 'json.data' );
- my $encoding = 'cp932';
- my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
-
- # or you can write the below code.
- #
- # open( my $fh, "<:encoding($encoding)", 'json.data' );
- # $unicode_json_text = <$fh>;
-
- In this case, C<$unicode_json_text> is of course UNICODE string.
- So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable.
-
- $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
-
- Or C<encode 'utf8'> and C<decode_json>:
-
- $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
- # this way is not efficient.
-
- And now, you want to convert your C<$perl_scalar> into JSON data and
- send it to an outer world - a network or a file content, and so on.
-
- Your data usually contains UNICODE strings and you want the converted data to be encoded
- in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
-
- print encode_json( $perl_scalar ); # to a network? file? or display?
- # or
- print $json->utf8->encode( $perl_scalar );
-
- If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
- for some reason, then its characters are regarded as B<latin1> for perl
- (because it does not concern with your $encoding).
- You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable.
- Note that the resulted text is a UNICODE string but no problem to print it.
-
- # $perl_scalar contains $encoding encoded string values
- $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
- # $unicode_json_text consists of characters less than 0x100
- print $unicode_json_text;
-
- Or C<decode $encoding> all string values and C<encode_json>:
-
- $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
- # ... do it to each string values, then encode_json
- $json_text = encode_json( $perl_scalar );
-
- This method is a proper way but probably not efficient.
-
- See to L<Encode>, L<perluniintro>.
-
-
- =head1 METHODS
+ This section is also taken from JSON::XS.
- Basically, check to L<JSON> or L<JSON::XS>.
+ The object oriented interface lets you configure your own encoding or
+ decoding style, within the limits of supported formats.
=head2 new
$json = JSON::PP->new
- Returns a new JSON::PP object that can be used to de/encode JSON
- strings.
-
- All boolean flags described below are by default I<disabled>.
+ Creates a new JSON::PP object that can be used to de/encode JSON
+ strings. All boolean flags described below are by default I<disabled>.
- The mutators for flags all return the JSON object again and thus calls can
+ The mutators for flags all return the JSON::PP object again and thus calls can
be chained:
my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
@@ -65206,16 +66975,23 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_ascii
- If $enable is true (or missing), then the encode method will not generate characters outside
- the code range 0..127. Any Unicode characters outside that range will be escaped using either
- a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
- (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
+ If C<$enable> is true (or missing), then the C<encode> method will not
+ generate characters outside the code range C<0..127> (which is ASCII). Any
+ Unicode characters outside that range will be escaped using either a
+ single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
+ as per RFC4627. The resulting encoded JSON text can be treated as a native
+ Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
+ or any other superset of ASCII.
+
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags. This results
+ in a faster and more compact format.
- In Perl 5.005, there is no character having high value (more than 255).
- See to L<UNICODE HANDLING ON PERLS>.
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
- If $enable is false, then the encode method will not escape Unicode characters unless
- required by the JSON syntax or other flags. This results in a faster and more compact format.
+ The main use for this flag is to produce JSON texts that can be
+ transmitted over a 7-bit channel, as the encoded JSON texts will not
+ contain any 8 bit characters.
JSON::PP->new->ascii(1)->encode([chr 0x10401])
=> ["\ud801\udc01"]
@@ -65226,16 +67002,28 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_latin1
- If $enable is true (or missing), then the encode method will encode the resulting JSON
- text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
+ outside the code range C<0..255>. The resulting string can be treated as a
+ latin1-encoded JSON text or a native Unicode string. The C<decode> method
+ will not be affected in any way by this flag, as C<decode> by default
+ expects Unicode, which is a strict superset of latin1.
- If $enable is false, then the encode method will not escape Unicode characters
- unless required by the JSON syntax or other flags.
+ If C<$enable> is false, then the C<encode> method will not escape Unicode
+ characters unless required by the JSON syntax or other flags.
- JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+
+ The main use for this flag is efficiently encoding binary data as JSON
+ text, as most octets will not be escaped, resulting in a smaller encoded
+ size. The disadvantage is that the resulting JSON text is encoded
+ in latin1 (and must correctly be treated as such when storing and
+ transferring), a rare encoding for JSON. It is therefore most useful when
+ you want to store data structures known to contain binary data efficiently
+ in files or databases, not when talking to other JSON encoders/decoders.
- See to L<UNICODE HANDLING ON PERLS>.
+ JSON::PP->new->latin1->encode (["\x{89}\x{abc}"]
+ => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
=head2 utf8
@@ -65243,20 +67031,20 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_utf8
- If $enable is true (or missing), then the encode method will encode the JSON result
- into UTF-8, as required by many protocols, while the decode method expects to be handled
- an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
- characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
-
- (In Perl 5.005, any character outside the range 0..255 does not exist.
- See to L<UNICODE HANDLING ON PERLS>.)
+ If C<$enable> is true (or missing), then the C<encode> method will encode
+ the JSON result into UTF-8, as required by many protocols, while the
+ C<decode> method expects to be handled an UTF-8-encoded string. Please
+ note that UTF-8-encoded strings do not contain any characters outside the
+ range C<0..255>, they are thus useful for bytewise/binary I/O. In future
+ versions, enabling this option might enable autodetection of the UTF-16
+ and UTF-32 encoding families, as described in RFC4627.
- In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
- encoding families, as described in RFC4627.
+ If C<$enable> is false, then the C<encode> method will return the JSON
+ string as a (non-encoded) Unicode string, while C<decode> expects thus a
+ Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs
+ to be done yourself, e.g. using the Encode module.
- If $enable is false, then the encode method will return the JSON string as a (non-encoded)
- Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
- (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
+ See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
Example, output UTF-16BE-encoded JSON:
@@ -65268,18 +67056,13 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use Encode;
$object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
-
=head2 pretty
$json = $json->pretty([$enable])
This enables (or disables) all of the C<indent>, C<space_before> and
- C<space_after> flags in one call to generate the most readable
- (or most compact) form possible.
-
- Equivalent to:
-
- $json->indent->space_before->space_after
+ C<space_after> (and in the future possibly more) flags in one call to
+ generate the most readable (or most compact) form possible.
=head2 indent
@@ -65287,6 +67070,15 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_indent
+ If C<$enable> is true (or missing), then the C<encode> method will use a multiline
+ format as output, putting every array member or object/hash key-value pair
+ into its own line, indenting them properly.
+
+ If C<$enable> is false, no newlines or indenting will be produced, and the
+ resulting JSON text is guaranteed not to contain any C<newlines>.
+
+ This setting has no effect when decoding JSON texts.
+
The default indent space length is three.
You can use C<indent_length> to change the length.
@@ -65302,7 +67094,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
- This setting has no effect when decoding JSON texts.
+ This setting has no effect when decoding JSON texts. You will also
+ most likely combine this setting with C<space_after>.
Example, space_before enabled, space_after and indent disabled:
@@ -65375,6 +67168,28 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# neither this one...
]
+ =item * C-style multiple-line '/* */'-comments (JSON::PP only)
+
+ Whenever JSON allows whitespace, C-style multiple-line comments are additionally
+ allowed. Everything between C</*> and C<*/> is a comment, after which
+ more white-space and comments are allowed.
+
+ [
+ 1, /* this comment not allowed in JSON */
+ /* neither this one... */
+ ]
+
+ =item * C++-style one-line '//'-comments (JSON::PP only)
+
+ Whenever JSON allows whitespace, C++-style one-line comments are additionally
+ allowed. They are terminated by the first carriage-return or line-feed
+ character, after which more white-space and comments are allowed.
+
+ [
+ 1, // this comment not allowed in JSON
+ // neither this one...
+ ]
+
=back
=head2 canonical
@@ -65388,7 +67203,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
- of the same script).
+ of the same script, and can change even within the same run from 5.18
+ onwards).
This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
@@ -65397,8 +67213,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
This setting has no effect when decoding JSON texts.
- If you want your own sorting routine, you can give a code reference
- or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
+ This setting has currently no effect on tied hashes.
=head2 allow_nonref
@@ -65416,6 +67231,9 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
+ Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
+ resulting in an invalid JSON text:
+
JSON::PP->new->allow_nonref->encode ("Hello, World!")
=> "Hello, World!"
@@ -65425,18 +67243,17 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_allow_unknown
- If $enable is true (or missing), then "encode" will *not* throw an
+ If C<$enable> is true (or missing), then C<encode> will I<not> throw an
exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON "null" value.
- Note that blessed objects are not included here and are handled
- separately by c<allow_nonref>.
+ example, filehandles) but instead will encode a JSON C<null> value. Note
+ that blessed objects are not included here and are handled separately by
+ c<allow_blessed>.
- If $enable is false (the default), then "encode" will throw an
+ If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters anything it cannot encode as JSON.
- This option does not affect "decode" in any way, and it is
- recommended to leave it off unless you know your communications
- partner.
+ This option does not affect C<decode> in any way, and it is recommended to
+ leave it off unless you know your communications partner.
=head2 allow_blessed
@@ -65444,15 +67261,17 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_allow_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference. Instead, the value of the
- B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
- disabled or no C<TO_JSON> method found) or a representation of the
- object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
- encoded. Has no effect on C<decode>.
+ barf when it encounters a blessed reference that it cannot convert
+ otherwise. Instead, a JSON C<null> value is encoded instead of the object.
If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object.
+ exception when it encounters a blessed object that it cannot convert
+ otherwise.
+
+ This setting has no effect on C<decode>.
=head2 convert_blessed
@@ -65460,38 +67279,38 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_convert_blessed
+ See L<OBJECT SERIALISATION> for details.
+
If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
- on the object's class. If found, it will be called in scalar context
- and the resulting scalar will be encoded instead of the object. If no
- C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
- to do.
+ on the object's class. If found, it will be called in scalar context and
+ the resulting scalar will be encoded instead of the object.
The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
- usually in upper case letters and to avoid collisions with the C<to_json>
+ usually in upper case letters and to avoid collisions with any C<to_json>
function or method.
- This setting does not yet influence C<decode> in any way.
+ If C<$enable> is false (the default), then C<encode> will not consider
+ this type of conversion.
- If C<$enable> is false, then the C<allow_blessed> setting will decide what
- to do when a blessed object is found.
+ This setting has no effect on C<decode>.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument passed to the coderef
- is a reference to the newly-created hash. If the code references returns
- a single scalar (which need not be a reference), this value
- (i.e. a copy of that scalar to avoid aliasing) is inserted into the
- deserialised data structure. If it returns an empty list
- (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
- hash will be inserted. This setting can slow down decoding considerably.
+ time it decodes a JSON object. The only argument is a reference to the
+ newly-created hash. If the code references returns a single scalar (which
+ need not be a reference), this value (i.e. a copy of that scalar to avoid
+ aliasing) is inserted into the deserialised data structure. If it returns
+ an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the
+ original deserialised hash will be inserted. This setting can slow down
+ decoding considerably.
When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
@@ -65566,15 +67385,13 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$enabled = $json->get_shrink
- In JSON::XS, this flag resizes strings generated by either
- C<encode> or C<decode> to their minimum size possible.
- It will also try to downgrade any strings to octet-form if possible.
+ If C<$enable> is true (or missing), the string returned by C<encode> will
+ be shrunk (i.e. downgraded if possible).
- In JSON::PP, it is noop about resizing strings but tries
- C<utf8::downgrade> to the returned string by C<encode>.
- See to L<utf8>.
+ The actual definition of what shrink does might change in future versions,
+ but it will always try to save space at the expense of time.
- See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
+ If C<$enable> is false, then JSON::PP does nothing.
=head2 max_depth
@@ -65592,13 +67409,13 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
characters without their matching closing parenthesis crossed to reach a
given character in a string.
+ Setting the maximum depth to one disallows any nesting, so that ensures
+ that the object is only a single hash/object or array.
+
If no argument is given, the highest possible setting will be used, which
is rarely useful.
- See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
-
- When a large value (100 or more) was set and it de/encodes a deep nested object/text,
- it may raise a warning 'Deep recursion on subroutine' at the perl runtime phase.
+ See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 max_size
@@ -65621,12 +67438,8 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$json_text = $json->encode($perl_scalar)
- Converts the given Perl data structure (a simple scalar or a reference
- to a hash or array) to its JSON representation. Simple scalars will be
- converted into JSON string or number sequences, while references to arrays
- become JSON arrays and references to hashes become JSON objects. Undefined
- Perl values (e.g. C<undef>) become JSON C<null> values.
- References to the integers C<0> and C<1> are converted into C<true> and C<false>.
+ Converts the given Perl value or data structure to its JSON
+ representation. Croaks on error.
=head2 decode
@@ -65635,11 +67448,6 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
- JSON numbers and strings become simple Perl scalars. JSON arrays become
- Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
- C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
- C<null> becomes C<undef>.
-
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
@@ -65649,25 +67457,185 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
silently stop parsing there and return the number of characters consumed
so far.
- JSON->new->decode_prefix ("[1] the tail")
- => ([], 3)
+ This is useful if your JSON texts are not delimited by an outer protocol
+ and you need to know where the JSON text ends.
+
+ JSON::PP->new->decode_prefix ("[1] the tail")
+ => ([1], 3)
+
+ =head1 FLAGS FOR JSON::PP ONLY
+
+ The following flags and properties are for JSON::PP only. If you use
+ any of these, you can't make your application run faster by replacing
+ JSON::PP with JSON::XS. If you need these and also speed boost,
+ try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which
+ supports some of these.
+
+ =head2 allow_singlequote
+
+ $json = $json->allow_singlequote([$enable])
+ $enabled = $json->get_allow_singlequote
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain strings that begin and end with
+ single quotation marks. C<encode> will not be affected in anyway.
+ I<Be aware that this option makes you accept invalid JSON texts
+ as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->allow_singlequote->decode(qq|{"foo":'bar'}|);
+ $json->allow_singlequote->decode(qq|{'foo':"bar"}|);
+ $json->allow_singlequote->decode(qq|{'foo':'bar'}|);
+
+ =head2 allow_barekey
+
+ $json = $json->allow_barekey([$enable])
+ $enabled = $json->get_allow_barekey
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain JSON objects whose names don't
+ begin and end with quotation marks. C<encode> will not be affected
+ in anyway. I<Be aware that this option makes you accept invalid JSON
+ texts as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->allow_barekey->decode(qq|{foo:"bar"}|);
+
+ =head2 allow_bignum
+
+ $json = $json->allow_bignum([$enable])
+ $enabled = $json->get_allow_bignum
+
+ If C<$enable> is true (or missing), then C<decode> will convert
+ big integers Perl cannot handle as integer into L<Math::BigInt>
+ objects and convert floating numbers into L<Math::BigFloat>
+ objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat>
+ objects into JSON numbers.
+
+ $json->allow_nonref->allow_bignum;
+ $bigfloat = $json->decode('2.000000000000000000000000001');
+ print $json->encode($bigfloat);
+ # => 2.000000000000000000000000001
+
+ See also L<MAPPING>.
+
+ =head2 loose
+
+ $json = $json->loose([$enable])
+ $enabled = $json->get_loose
+
+ If C<$enable> is true (or missing), then C<decode> will accept
+ invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
+ characters. C<encode> will not be affected in anyway.
+ I<Be aware that this option makes you accept invalid JSON texts
+ as if they were valid!>. I suggest only to use this option to
+ parse application-specific files written by humans (configuration
+ files, resource files etc.)
+
+ If C<$enable> is false (the default), then C<decode> will only accept
+ valid JSON texts.
+
+ $json->loose->decode(qq|["abc
+ def"]|);
+
+ =head2 escape_slash
+
+ $json = $json->escape_slash([$enable])
+ $enabled = $json->get_escape_slash
+
+ If C<$enable> is true (or missing), then C<encode> will explicitly
+ escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of
+ XSS (cross site scripting) that may be caused by C<< </script> >>
+ in a JSON text, with the cost of bloating the size of JSON texts.
+
+ This option may be useful when you embed JSON in HTML, but embedding
+ arbitrary JSON in HTML (by some HTML template toolkit or by string
+ interpolation) is risky in general. You must escape necessary
+ characters in correct order, depending on the context.
+
+ C<decode> will not be affected in anyway.
+
+ =head2 indent_length
+
+ $json = $json->indent_length($number_of_spaces)
+ $length = $json->get_indent_length
+
+ This option is only useful when you also enable C<indent> or C<pretty>.
+
+ JSON::XS indents with three spaces when you C<encode> (if requested
+ by C<indent> or C<pretty>), and the number cannot be changed.
+ JSON::PP allows you to change/get the number of indent spaces with these
+ mutator/accessor. The default number of spaces is three (the same as
+ JSON::XS), and the acceptable range is from C<0> (no indentation;
+ it'd be better to disable indentation by C<indent(0)>) to C<15>.
+
+ =head2 sort_by
+
+ $json = $json->sort_by($code_ref)
+ $json = $json->sort_by($subroutine_name)
+
+ If you just want to sort keys (names) in JSON objects when you
+ C<encode>, enable C<canonical> option (see above) that allows you to
+ sort object keys alphabetically.
+
+ If you do need to sort non-alphabetically for whatever reasons,
+ you can give a code reference (or a subroutine name) to C<sort_by>,
+ then the argument will be passed to Perl's C<sort> built-in function.
+
+ As the sorting is done in the JSON::PP scope, you usually need to
+ prepend C<JSON::PP::> to the subroutine name, and the special variables
+ C<$a> and C<$b> used in the subrontine used by C<sort> function.
+
+ Example:
+
+ my %ORDER = (id => 1, class => 2, name => 3);
+ $json->sort_by(sub {
+ ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999)
+ or $JSON::PP::a cmp $JSON::PP::b
+ });
+ print $json->encode([
+ {name => 'CPAN', id => 1, href => 'http://cpan.org'}
+ ]);
+ # [{"id":1,"name":"CPAN","href":"http://cpan.org"}]
+
+ Note that C<sort_by> affects all the plain hashes in the data structure.
+ If you need finer control, C<tie> necessary hashes with a module that
+ implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>).
+ C<canonical> and C<sort_by> don't affect the key order in C<tie>d
+ hashes.
+
+ use Hash::Ordered;
+ tie my %hash, 'Hash::Ordered',
+ (name => 'CPAN', id => 1, href => 'http://cpan.org');
+ print $json->encode([\%hash]);
+ # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept
=head1 INCREMENTAL PARSING
- Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
+ This section is also taken from JSON::XS.
- In some cases, there is the need for incremental parsing of JSON texts.
- This module does allow you to parse a JSON stream incrementally.
- It does so by accumulating text until it has a full JSON object, which
- it then can decode. This process is similar to using C<decode_prefix>
- to see if a full JSON object is available, but is much more efficient
- (and can be implemented with a minimum of method calls).
+ In some cases, there is the need for incremental parsing of JSON
+ texts. While this module always has to keep both JSON text and resulting
+ Perl data structure in memory at one time, it does allow you to parse a
+ JSON stream incrementally. It does so by accumulating text until it has
+ a full JSON object, which it then can decode. This process is similar to
+ using C<decode_prefix> to see if a full JSON object is available, but
+ is much more efficient (and can be implemented with a minimum of method
+ calls).
- This module will only attempt to parse the JSON text once it is sure it
+ JSON::PP will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
- early as the full parser, for example, it doesn't detect parenthesis
- mismatches. The only thing it guarantees is that it starts decoding as
+ early as the full parser, for example, it doesn't detect mismatched
+ parentheses. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
@@ -65702,15 +67670,16 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
- otherwise. For this to work, there must be no separators between the JSON
- objects or arrays, instead they must be concatenated back-to-back. If
- an error occurs, an exception will be raised as in the scalar context
- case. Note that in this case, any previously-parsed JSON texts will be
- lost.
+ otherwise. For this to work, there must be no separators (other than
+ whitespace) between the JSON objects or arrays, instead they must be
+ concatenated back-to-back. If an error occurs, an exception will be
+ raised as in the scalar context case. Note that in this case, any
+ previously-parsed JSON texts will be lost.
- Example: Parse some JSON arrays/objects in a given string and return them.
+ Example: Parse some JSON arrays/objects in a given string and return
+ them.
- my @objs = JSON->new->incr_parse ("[5][7][1,2]");
+ my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]");
=head2 incr_text
@@ -65724,27 +67693,26 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
real world conditions). As a special exception, you can also call this
method before having parsed anything.
+ That means you can only use this function to look at or manipulate text
+ before or after complete JSON objects, not while the parser is in the
+ middle of parsing a JSON object.
+
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
- $json->incr_text =~ s/\s*,\s*//;
-
- In Perl 5.005, C<lvalue> attribute is not available.
- You must write codes like the below:
-
- $string = $json->incr_text;
- $string =~ s/\s*,\s*//;
- $json->incr_text( $string );
-
=head2 incr_skip
$json->incr_skip
- This will reset the state of the incremental parser and will remove the
- parsed text from the input buffer. This is useful after C<incr_parse>
- died, in which case the input buffer and incremental parser state is left
- unchanged, to skip the text parsed so far and to reset the parse state.
+ This will reset the state of the incremental parser and will remove
+ the parsed text from the input buffer so far. This is useful after
+ C<incr_parse> died, in which case the input buffer and incremental parser
+ state is left unchanged, to skip the text parsed so far and to reset the
+ parse state.
+
+ The difference to C<incr_reset> is that only text until the parse error
+ occurred is removed.
=head2 incr_reset
@@ -65757,148 +67725,18 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
ignore any trailing data, which means you have to reset the parser after
each successful decode.
- See to L<JSON::XS/INCREMENTAL PARSING> for examples.
-
-
- =head1 JSON::PP OWN METHODS
-
- =head2 allow_singlequote
-
- $json = $json->allow_singlequote([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- JSON strings quoted by single quotations that are invalid JSON
- format.
-
- $json->allow_singlequote->decode({"foo":'bar'});
- $json->allow_singlequote->decode({'foo':"bar"});
- $json->allow_singlequote->decode({'foo':'bar'});
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
-
- =head2 allow_barekey
-
- $json = $json->allow_barekey([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will accept
- bare keys of JSON object that are invalid JSON format.
-
- As same as the C<relaxed> option, this option may be used to parse
- application-specific files written by humans.
-
- $json->allow_barekey->decode('{foo:"bar"}');
-
- =head2 allow_bignum
-
- $json = $json->allow_bignum([$enable])
-
- If C<$enable> is true (or missing), then C<decode> will convert
- the big integer Perl cannot handle as integer into a L<Math::BigInt>
- object and convert a floating number (any) into a L<Math::BigFloat>.
-
- On the contrary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers with C<allow_blessed> enable.
-
- $json->allow_nonref->allow_blessed->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
-
- See to L<JSON::XS/MAPPING> about the normal conversion of JSON number.
-
- =head2 loose
-
- $json = $json->loose([$enable])
-
- The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
- and the module doesn't allow to C<decode> to these (except for \x2f).
- If C<$enable> is true (or missing), then C<decode> will accept these
- unescaped strings.
-
- $json->loose->decode(qq|["abc
- def"]|);
-
- See L<JSON::XS/SSECURITY CONSIDERATIONS>.
-
- =head2 escape_slash
-
- $json = $json->escape_slash([$enable])
-
- According to JSON Grammar, I<slash> (U+002F) is escaped. But default
- JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
-
- If C<$enable> is true (or missing), then C<encode> will escape slashes.
-
- =head2 indent_length
-
- $json = $json->indent_length($length)
-
- JSON::XS indent space length is 3 and cannot be changed.
- JSON::PP set the indent space length with the given $length.
- The default is 3. The acceptable range is 0 to 15.
-
- =head2 sort_by
-
- $json = $json->sort_by($function_name)
- $json = $json->sort_by($subroutine_ref)
-
- If $function_name or $subroutine_ref are set, its sort routine are used
- in encoding JSON objects.
-
- $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- $js = $pc->sort_by('own_sort')->encode($obj);
- # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
-
- sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
-
- As the sorting routine runs in the JSON::PP scope, the given
- subroutine name and the special variables C<$a>, C<$b> will begin
- 'JSON::PP::'.
-
- If $integer is set, then the effect is same as C<canonical> on.
-
- =head1 INTERNAL
-
- For developers.
-
- =over
-
- =item PP_encode_box
-
- Returns
-
- {
- depth => $depth,
- indent_count => $indent_count,
- }
-
-
- =item PP_decode_box
-
- Returns
-
- {
- text => $text,
- at => $at,
- ch => $ch,
- len => $len,
- depth => $depth,
- encoding => $encoding,
- is_valid_utf8 => $is_valid_utf8,
- };
-
- =back
-
=head1 MAPPING
- This section is copied from JSON::XS and modified to C<JSON::PP>.
- JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
+ Most of this section is also taken from JSON::XS.
+
+ This section describes how JSON::PP maps Perl values to JSON values and
+ vice versa. These mappings are designed to "do the right thing" in most
+ circumstances automatically, preserving round-tripping characteristics
+ (what you put in comes out as something equivalent).
- See to L<JSON::XS/MAPPING>.
+ For the more enlightened: note that in the following descriptions,
+ lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
+ refers to the abstract Perl language itself.
=head2 JSON -> PERL
@@ -65907,7 +67745,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=item object
A JSON object becomes a reference to a hash in Perl. No ordering of object
- keys is preserved (JSON does not preserver object key ordering itself).
+ keys is preserved (JSON does not preserve object key ordering itself).
=item array
@@ -65927,7 +67765,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.
- If the number consists of digits only, C<JSON> will try to represent
+ If the number consists of digits only, JSON::PP will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
@@ -65941,36 +67779,30 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
- floating point, C<JSON> only guarantees precision up to but not including
+ floating point, JSON::PP only guarantees precision up to but not including
the least significant bit.
- When C<allow_bignum> is enable, the big integers
- and the numeric can be optionally converted into L<Math::BigInt> and
- L<Math::BigFloat> objects.
+ When C<allow_bignum> is enabled, big integer values and any numeric
+ values will be converted into L<Math::BigInt> and L<Math::BigFloat>
+ objects respectively, without becoming string scalars or losing
+ precision.
=item true, false
These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
C<1> and C<0>. You can check whether a scalar is a JSON boolean by using
- the C<JSON::is_bool> function.
-
- print JSON::PP::true . "\n";
- => true
- print JSON::PP::true + 1;
- => 1
-
- ok(JSON::true eq '1');
- ok(JSON::true == 1);
-
- C<JSON> will install these missing overloading features to the backend modules.
-
+ the C<JSON::PP::is_bool> function.
=item null
A JSON null atom becomes C<undef> in Perl.
- C<JSON::PP::null> returns C<undef>.
+ =item shell-style comments (C<< # I<text> >>)
+
+ As a nonstandard extension to the JSON syntax that is enabled by the
+ C<relaxed> setting, shell-style comments are allowed. They can start
+ anywhere outside strings and go till the end of the line.
=back
@@ -65985,16 +67817,14 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=item hash references
- Perl hash references become JSON objects. As there is no inherent ordering
- in hash keys (or JSON objects), they will usually be encoded in a
- pseudo-random order that can change between runs of the same program but
- stays generally the same within a single run of a program. C<JSON>
- optionally sort the hash keys (determined by the I<canonical> flag), so
- the same data structure will serialise to the same JSON text (given same
- settings and version of JSON::XS), but this incurs a runtime overhead
- and is only rarely useful, e.g. when you want to compare some JSON text
- against another for equality.
-
+ Perl hash references become JSON objects. As there is no inherent
+ ordering in hash keys (or JSON objects), they will usually be encoded
+ in a pseudo-random order. JSON::PP can optionally sort the hash keys
+ (determined by the I<canonical> flag and/or I<sort_by> property), so
+ the same data structure will serialise to the same JSON text (given
+ same settings and version of JSON::PP), but this incurs a runtime
+ overhead and is only rarely useful, e.g. when you want to compare some
+ JSON text against another for equality.
=item array references
@@ -66005,31 +67835,30 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
Other unblessed references are generally not allowed and will cause an
exception to be thrown, except for references to the integers C<0> and
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
- also use C<JSON::false> and C<JSON::true> to improve readability.
+ also use C<JSON::PP::false> and C<JSON::PP::true> to improve
+ readability.
- to_json [\0,JSON::PP::true] # yields [false,true]
+ to_json [\0, JSON::PP::true] # yields [false,true]
- =item JSON::PP::true, JSON::PP::false, JSON::PP::null
+ =item JSON::PP::true, JSON::PP::false
These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.
- JSON::PP::null returns C<undef>.
+ =item JSON::PP::null
- =item blessed objects
+ This special value becomes JSON null.
- Blessed objects are not directly representable in JSON. See the
- C<allow_blessed> and C<convert_blessed> methods on various options on
- how to deal with this: basically, you can choose between throwing an
- exception, encoding the reference as if it weren't blessed, or provide
- your own serialiser method.
+ =item blessed objects
- See to L<convert_blessed>.
+ Blessed objects are not directly representable in JSON, but C<JSON::PP>
+ allows various ways of handling objects. See L<OBJECT SERIALISATION>,
+ below, for details.
=item simple scalars
Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
+ difficult objects to encode: JSON::PP will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:
@@ -66051,6 +67880,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
"$x"; # stringified
$x .= ""; # another, more awkward way to stringify
print $x; # perl does it for you, too, quite often
+ # (but for older perls)
You can force the type to be a number by numifying it:
@@ -66058,7 +67888,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$x += 0; # numify it, ensuring it will be dumped as a number
$x *= 1; # same thing, the choice is yours.
- You can not currently force the type in other, less obscure, ways.
+ You cannot currently force the type in other, less obscure, ways.
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
@@ -66067,94 +67897,171 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.
- =item Big Number
+ JSON::PP (and JSON::XS) trusts what you pass to C<encode> method
+ (or C<encode_json> function) is a clean, validated data structure with
+ values that can be represented as valid JSON values only, because it's
+ not from an external data source (as opposed to JSON texts you pass to
+ C<decode> or C<decode_json>, which JSON::PP considers tainted and
+ doesn't trust). As JSON::PP doesn't know exactly what you and consumers
+ of your JSON texts want the unexpected values to be (you may want to
+ convert them into null, or to stringify them with or without
+ normalisation (string representation of infinities/NaN may vary
+ depending on platforms), or to croak without conversion), you're advised
+ to do what you and your consumers need before you encode, and also not
+ to numify values that may start with values that look like a number
+ (including infinities/NaN), without validating.
- When C<allow_bignum> is enable,
- C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers.
+ =back
+ =head2 OBJECT SERIALISATION
- =back
+ As for Perl objects, JSON::PP only supports a pure JSON representation (without the ability to deserialise the object automatically again).
- =head1 UNICODE HANDLING ON PERLS
+ =head3 SERIALISATION
- If you do not know about Unicode on Perl well,
- please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
+ What happens when C<JSON::PP> encounters a Perl object depends on the
+ C<allow_blessed>, C<convert_blessed> and C<allow_bignum> settings, which are
+ used in this order:
- =head2 Perl 5.8 and later
+ =over 4
- Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
+ =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
- $json->allow_nonref->encode(chr hex 3042);
- $json->allow_nonref->encode(chr hex 12345);
+ In this case, the C<TO_JSON> method of the object is invoked in scalar
+ context. It must return a single scalar that can be directly encoded into
+ JSON. This scalar replaces the object in the JSON text.
- Returns C<"\u3042"> and C<"\ud808\udf45"> respectively.
+ For example, the following C<TO_JSON> method will convert all L<URI>
+ objects to JSON strings when serialised. The fact that these values
+ originally were L<URI> objects is lost.
+
+ sub URI::TO_JSON {
+ my ($uri) = @_;
+ $uri->as_string
+ }
+
+ =item 2. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
- $json->allow_nonref->decode('"\u3042"');
- $json->allow_nonref->decode('"\ud808\udf45"');
+ The object will be serialised as a JSON number value.
+
+ =item 3. C<allow_blessed> is enabled.
+
+ The object will be serialised as a JSON null value.
+
+ =item 4. none of the above
- Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
+ If none of the settings are enabled or the respective methods are missing,
+ C<JSON::PP> throws an exception.
- Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
- so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
+ =back
+ =head1 ENCODING/CODESET FLAG NOTES
- =head2 Perl 5.6
+ This section is taken from JSON::XS.
- Perl can handle Unicode and the JSON::PP de/encode methods also work.
+ The interested reader might have seen a number of flags that signify
+ encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
+ some confusion on what these do, so here is a short comparison:
- =head2 Perl 5.005
+ C<utf8> controls whether the JSON text created by C<encode> (and expected
+ by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
+ control whether C<encode> escapes character values outside their respective
+ codeset range. Neither of these flags conflict with each other, although
+ some combinations make less sense than others.
- Perl 5.005 is a byte semantics world -- all strings are sequences of bytes.
- That means the unicode handling is not available.
+ Care has been taken to make all flags symmetrical with respect to
+ C<encode> and C<decode>, that is, texts encoded with any combination of
+ these flag values will be correctly decoded when the same flags are used
+ - in general, if you use different flag settings while encoding vs. when
+ decoding you likely have a bug somewhere.
- In encoding,
+ Below comes a verbose discussion of these flags. Note that a "codeset" is
+ simply an abstract set of character-codepoint pairs, while an encoding
+ takes those codepoint numbers and I<encodes> them, in our case into
+ octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
+ and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
+ the same time, which can be confusing.
- $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
- $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
+ =over 4
- Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
- as C<$value % 256>, so the above codes are equivalent to :
+ =item C<utf8> flag disabled
- $json->allow_nonref->encode(chr 66);
- $json->allow_nonref->encode(chr 69);
+ When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
+ and expect Unicode strings, that is, characters with high ordinal Unicode
+ values (> 255) will be encoded as such characters, and likewise such
+ characters are decoded as-is, no changes to them will be done, except
+ "(re-)interpreting" them as Unicode codepoints or Unicode characters,
+ respectively (to Perl, these are the same thing in strings unless you do
+ funny/weird/dumb stuff).
- In decoding,
+ This is useful when you want to do the encoding yourself (e.g. when you
+ want to have UTF-16 encoded JSON texts) or when some other layer does
+ the encoding for you (for example, when printing to a terminal using a
+ filehandle that transparently encodes to UTF-8 you certainly do NOT want
+ to UTF-8 encode your data first and have Perl encode it another time).
- $json->decode('"\u00e3\u0081\u0082"');
+ =item C<utf8> flag enabled
- The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
- japanese character (C<HIRAGANA LETTER A>).
- And if it is represented in Unicode code point, C<U+3042>.
+ If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
+ characters using the corresponding UTF-8 multi-byte sequence, and will
+ expect your input strings to be encoded as UTF-8, that is, no "character"
+ of the input string must have any value > 255, as UTF-8 does not allow
+ that.
- Next,
+ The C<utf8> flag therefore switches between two modes: disabled means you
+ will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
+ octet/binary string in Perl.
- $json->decode('"\u3042"');
+ =item C<latin1> or C<ascii> flags enabled
- We ordinary expect the returned value is a Unicode character C<U+3042>.
- But here is 5.005 world. This is C<0xE3 0x81 0x82>.
+ With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
+ with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
+ characters as specified by the C<utf8> flag.
- $json->decode('"\ud808\udf45"');
+ If C<utf8> is disabled, then the result is also correctly encoded in those
+ character sets (as both are proper subsets of Unicode, meaning that a
+ Unicode string with all character values < 256 is the same thing as a
+ ISO-8859-1 string, and a Unicode string with all character values < 128 is
+ the same thing as an ASCII string in Perl).
- This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
+ If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
+ regardless of these flags, just some more characters will be escaped using
+ C<\uXXXX> then before.
+ Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
+ encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
+ encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
+ a subset of Unicode), while ASCII is.
- =head1 TODO
+ Surprisingly, C<decode> will ignore these flags and so treat all input
+ values as governed by the C<utf8> flag. If it is disabled, this allows you
+ to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
+ Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
- =over
+ So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
+ they only govern when the JSON output engine escapes a character or not.
- =item speed
+ The main use for C<latin1> is to relatively efficiently store binary data
+ as JSON, at the expense of breaking compatibility with most JSON decoders.
- =item memory saving
+ The main use for C<ascii> is to force the output to not contain characters
+ with values > 127, which means you can interpret the resulting string
+ as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
+ 8-bit-encoding, and still get the same data structure back. This is useful
+ when your channel for JSON transfer is not 8-bit clean or the encoding
+ might be mangled in between (e.g. in mail), and works because ASCII is a
+ proper subset of most 8-bit and multibyte encodings in use in the world.
=back
-
=head1 SEE ALSO
- Most of the document are copied and modified from JSON::XS doc.
+ The F<json_pp> command line utility for quick experiments.
+
+ L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives.
+ L<JSON> and L<JSON::MaybeXS> for easy migration.
- L<JSON::XS>
+ L<JSON::backportPP::Compat5005> and L<JSON::backportPP::Compat5006> for older perl users.
RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
@@ -66165,7 +68072,7 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=head1 COPYRIGHT AND LICENSE
- Copyright 2007-2012 by Makamaka Hannyaharamitu
+ Copyright 2007-2016 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
@@ -66174,6 +68081,23 @@ $fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
JSON_BACKPORTPP
$fatpacked{"JSON/backportPP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_BOOLEAN';
+ package # This is JSON::backportPP
+ JSON::PP::Boolean;
+
+ use strict;
+ use overload (
+ "0+" => sub { ${$_[0]} },
+ "++" => sub { $_[0] = ${$_[0]} + 1 },
+ "--" => sub { $_[0] = ${$_[0]} - 1 },
+ fallback => 1,
+ );
+
+ $JSON::backportPP::Boolean::VERSION = '2.94';
+
+ 1;
+
+ __END__
+
=head1 NAME
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
@@ -66184,20 +68108,12 @@ $fatpacked{"JSON/backportPP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
=head1 DESCRIPTION
- This module exists only to provide overload resolution for Storable
- and similar modules. See L<JSON::PP> for more info about this class.
-
- =cut
-
- use JSON::backportPP ();
- use strict;
-
- 1;
+ This module exists only to provide overload resolution for Storable and similar modules. See
+ L<JSON::PP> for more info about this class.
=head1 AUTHOR
- This idea is from L<JSON::XS::Boolean> written by
- Marc Lehmann <schmorp[at]schmorp.de>
+ This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
=cut
@@ -66522,7 +68438,19 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use Module::CPANfile::Environment;
use Module::CPANfile::Requirement;
- our $VERSION = '1.1000';
+ our $VERSION = '1.1002';
+
+ BEGIN {
+ if (${^TAINT}) {
+ *untaint = sub {
+ my $str = shift;
+ ($str) = $str =~ /^(.+)$/s;
+ $str;
+ };
+ } else {
+ *untaint = sub { $_[0] };
+ }
+ }
sub new {
my($class, $file) = @_;
@@ -66533,7 +68461,7 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my($proto, $file) = @_;
my $self = ref $proto ? $proto : $proto->new;
- $self->parse($file || Cwd::abs_path('cpanfile'));
+ $self->parse($file || _default_cpanfile());
$self;
}
@@ -66552,6 +68480,8 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
join '', <$fh>;
};
+ $code = untaint $code;
+
my $env = Module::CPANfile::Environment->new($file);
$env->parse($code) or die $@;
@@ -66648,6 +68578,11 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$value;
}
+ sub _default_cpanfile {
+ my $file = Cwd::abs_path('cpanfile');
+ untaint $file;
+ }
+
sub to_string {
my($self, $include_empty) = @_;
@@ -67187,1185 +69122,619 @@ $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE
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; # git description: v1.000026-12-g9b12bf1
-
- # 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).
-
- sub __clean_eval { eval $_[0] }
+$fatpacked{"Module/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_READER';
+ package Module::Reader;
+ BEGIN { require 5.006 }
use strict;
use warnings;
- our $VERSION = '1.000027';
-
- 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'}) {
- require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
- Log::Contextual->import('log_info',
- '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
- );
- } 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;
+ our $VERSION = '0.003003';
+ $VERSION = eval $VERSION;
- 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 arisdottle
- $PKG_FIRST_WORD_REGEXP # a package word
- (?:
- (?: :: )+ ### arisdottle (allow one or many times)
- $PKG_ADDL_WORD_REGEXP ### a package word
- )* # ^ zero, one or many times
- (?:
- :: # allow trailing arisdottle
- )?
- }x;
-
- my $PKG_REGEXP = qr{ # match a package declaration
- ^[\s\{;]* # intro chars on a line
- package # the word 'package'
- \s+ # whitespace
- ($PKG_NAME_REGEXP) # a package name
- \s* # optional whitespace
- ($V_NUM_REGEXP)? # optional version number
- \s* # optional whitesapce
- [;\{] # semicolon line terminator or block start (since 5.16)
- }x;
-
- my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
- ([\$*]) # sigil - $ or *
- (
- ( # optional leading package name
- (?:::|\')? # possibly starting like just :: (a la $::VERSION)
- (?:\w+(?:::|\'))* # Foo::Bar:: ...
- )?
- VERSION
- )\b
- }x;
-
- my $VERS_REGEXP = qr{ # match a VERSION definition
- (?:
- \(\s*$VARNAME_REGEXP\s*\) # with parens
- |
- $VARNAME_REGEXP # without parens
- )
- \s*
- =[^=~>] # = but not ==, nor =~, 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 );
+ use Exporter (); BEGIN { *import = \&Exporter::import }
+ our @EXPORT_OK = qw(module_content module_handle);
+ our %EXPORT_TAGS = (all => [@EXPORT_OK]);
- return $class->_init(undef, $filename, @_, handle => $handle);
+ use File::Spec ();
+ use Scalar::Util qw(reftype refaddr openhandle);
+ use Carp qw(croak);
+ use Config ();
+ use Errno qw(EACCES);
+ use constant _OPEN_LAYERS => "$]" >= 5.008_000 ? ':' : '';
+ use constant _ABORT_ON_EACCES => "$]" >= 5.017_001;
+ use constant _ALLOW_PREFIX => "$]" >= 5.008009;
+ use constant _VMS => $^O eq 'VMS' && !!require VMS::Filespec;
+ use constant _WIN32 => $^O eq 'MSWin32';
+ use constant _PMC_ENABLED => !(
+ exists &Config::non_bincompat_options
+ ? grep { $_ eq 'PERL_DISABLE_PMC' } Config::non_bincompat_options()
+ : $Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/
+ );
+ use constant _FAKE_FILE_FORMAT => do {
+ my $uvx = $Config::Config{uvxformat} || '';
+ $uvx =~ tr/"\0//d;
+ $uvx ||= 'lx';
+ "/loader/0x%$uvx/%s"
+ };
+ sub _mod_to_file {
+ my $module = shift;
+ (my $file = "$module.pm") =~ s{::}{/}g;
+ $file;
}
-
- 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);
+ sub module_content {
+ my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
+ my $module = shift;
+ $opts->{inc} = [@_]
+ if @_;
+ __PACKAGE__->new($opts)->module($module)->content;
}
- {
-
- my $compare_versions = sub {
- my ($v1, $op, $v2) = @_;
- $v1 = version->new($v1)
- unless UNIVERSAL::isa($v1,'version');
-
- my $eval_str = "\$v1 $op \$v2";
- my $result = eval $eval_str;
- log_info { "error comparing versions: '$eval_str' $@" } if $@;
-
- return $result;
- };
-
- my $normalize_version = sub {
- my ($version) = @_;
- if ( $version =~ /[=<>!,]/ ) { # logic, not just version
- # take as is without modification
- }
- elsif ( ref $version eq 'version' ) { # version objects
- $version = $version->is_qv ? $version->normal : $version->stringify;
- }
- elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
- # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
- $version = "v$version";
- }
- else {
- # leave alone
- }
- return $version;
- };
-
- # separate out some of the conflict resolution logic
-
- my $resolve_module_versions = sub {
- my $packages = shift;
-
- my( $file, $version );
- my $err = '';
- foreach my $p ( @$packages ) {
- if ( defined( $p->{version} ) ) {
- if ( defined( $version ) ) {
- if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
- $err .= " $p->{file} ($p->{version})\n";
- } else {
- # same version declared multiple times, ignore
- }
- } else {
- $file = $p->{file};
- $version = $p->{version};
- }
- }
- $file ||= $p->{file} if defined( $p->{file} );
- }
-
- if ( $err ) {
- $err = " $file ($version)\n" . $err;
- }
-
- my %result = (
- file => $file,
- version => $version,
- err => $err
- );
+ sub module_handle {
+ my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
+ my $module = shift;
+ $opts->{inc} = [@_]
+ if @_;
+ __PACKAGE__->new($opts)->module($module)->handle;
+ }
- return \%result;
- };
+ sub new {
+ my $class = shift;
+ my %options;
+ if (@_ == 1 && ref $_[-1]) {
+ %options = %{(pop)};
+ }
+ elsif (@_ % 2 == 0) {
+ %options = @_;
+ }
+ else {
+ croak "Expected hash ref, or key value pairs. Got ".@_." arguments.";
+ }
- sub provides {
- my $class = shift;
+ $options{inc} ||= \@INC;
+ $options{found} = \%INC
+ if exists $options{found} && $options{found} eq 1;
+ $options{pmc} = _PMC_ENABLED
+ if !exists $options{pmc};
+ $options{open} = 1
+ if !exists $options{open};
+ $options{abort_on_eacces} = _ABORT_ON_EACCES
+ if !exists $options{abort_on_eacces};
+ $options{check_hooks_for_nonsearchable} = 1
+ if !exists $options{check_hooks_for_nonsearchable};
+ bless \%options, $class;
+ }
- croak "provides() requires key/value pairs \n" if @_ % 2;
- my %args = @_;
+ sub module {
+ my ($self, $module) = @_;
+ $self->file(_mod_to_file($module));
+ }
- croak "provides() takes only one of 'dir' or 'files'\n"
- if $args{dir} && $args{files};
+ sub modules {
+ my ($self, $module) = @_;
+ $self->files(_mod_to_file($module));
+ }
- croak "provides() requires a 'version' argument"
- unless defined $args{version};
+ sub file {
+ my ($self, $file) = @_;
+ $self->_find($file);
+ }
- croak "provides() does not support version '$args{version}' metadata"
- unless grep { $args{version} eq $_ } qw/1.4 2/;
+ sub files {
+ my ($self, $file) = @_;
+ $self->_find($file, 1);
+ }
- $args{prefix} = 'lib' unless defined $args{prefix};
+ sub _searchable {
+ my $file = shift;
+ File::Spec->file_name_is_absolute($file) ? 0
+ : _WIN32 && $file =~ m{^\.\.?[/\\]} ? 0
+ : $file =~ m{^\.\.?/} ? 0
+ : 1
+ }
- 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});
- }
+ sub _find {
+ my ($self, $file, $all) = @_;
- # Now, fix up files with prefix
- if ( length $args{prefix} ) { # check in case disabled with q{}
- $args{prefix} =~ s{/$}{};
- for my $v ( values %$p ) {
- $v->{file} = "$args{prefix}/$v->{file}";
+ my @found;
+ eval {
+ if (my $found = $self->{found}) {
+ if (defined( my $full = $found->{$file} )) {
+ my $open = length ref $full ? $self->_open_ref($full, $file)
+ : $self->_open_file($full, $file);
+ push @found, $open
+ if $open;
}
}
-
- return $p
+ };
+ if (!$all) {
+ return $found[0]
+ if @found;
+ die $@
+ if $@;
}
- 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 $searchable = _searchable($file);
+ if (!$searchable) {
+ my $open = $self->_open_file($file);
+ if ($all) {
+ push @found, $open;
}
-
- # First, we enumerate all packages & versions,
- # separating into primary & alternative candidates
- my( %prime, %alt );
- foreach my $file (@files) {
- my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
- my @path = split( /\//, $mapped_filename );
- (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
-
- my $pm_info = $class->new_from_file( $file );
-
- foreach my $package ( $pm_info->packages_inside ) {
- next if $package eq 'main'; # main can appear numerous times, ignore
- next if $package eq 'DB'; # special debugging package, ignore
- next if grep /^_/, split( /::/, $package ); # private package, ignore
-
- my $version = $pm_info->version( $package );
-
- $prime_package = $package if lc($prime_package) eq lc($package);
- if ( $package eq $prime_package ) {
- if ( exists( $prime{$package} ) ) {
- croak "Unexpected conflict in '$package'; multiple versions found.\n";
- } else {
- $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
- $prime{$package}{file} = $mapped_filename;
- $prime{$package}{version} = $version if defined( $version );
- }
- } else {
- push( @{$alt{$package}}, {
- file => $mapped_filename,
- version => $version,
- } );
- }
- }
+ elsif ($open) {
+ return $open;
}
-
- # Then we iterate over all the packages found above, identifying conflicts
- # and selecting the "best" candidate for recording the file & version
- # for each package.
- foreach my $package ( keys( %alt ) ) {
- my $result = $resolve_module_versions->( $alt{$package} );
-
- if ( exists( $prime{$package} ) ) { # primary package selected
-
- if ( $result->{err} ) {
- # Use the selected primary package, but there are conflicting
- # errors among multiple alternative packages that need to be
- # reported
- log_info {
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- $result->{err}
- };
-
- } elsif ( defined( $result->{version} ) ) {
- # There is a primary package selected, and exactly one
- # alternative package
-
- if ( exists( $prime{$package}{version} ) &&
- defined( $prime{$package}{version} ) ) {
- # Unless the version of the primary package agrees with the
- # version of the alternative package, report a conflict
- if ( $compare_versions->(
- $prime{$package}{version}, '!=', $result->{version}
- )
- ) {
-
- log_info {
- "Found conflicting versions for package '$package'\n" .
- " $prime{$package}{file} ($prime{$package}{version})\n" .
- " $result->{file} ($result->{version})\n"
- };
- }
-
- } else {
- # The prime package selected has no version so, we choose to
- # use any alternative package that does have a version
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version};
- }
-
- } else {
- # no alt package found with a version, but we have a prime
- # package so we use it whether it has a version or not
- }
-
- } else { # No primary package was selected, use the best alternative
-
- if ( $result->{err} ) {
- log_info {
- "Found conflicting versions for package '$package'\n" .
- $result->{err}
- };
- }
-
- # Despite possible conflicting versions, we choose to record
- # something rather than nothing
- $prime{$package}{file} = $result->{file};
- $prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
- }
- }
-
- # Normalize versions. Can't use exists() here because of bug in YAML::Node.
- # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
- for (grep defined $_->{version}, values %prime) {
- $_->{version} = $normalize_version->( $_->{version} );
+ else {
+ croak "Can't locate $file";
}
-
- 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); # punt
+ my $search = $self->{inc};
+ for my $inc (@$search) {
+ my $open;
+ if (!$searchable) {
+ last
+ if !$self->{check_hooks_for_nonsearchable};
+ next
+ if !length ref $inc;
}
- else {
- if(grep /main/, @{$self->{packages}}) {
- $self->{module} = 'main';
+ eval {
+ if (!length ref $inc) {
+ my $full = _VMS ? VMS::Filespec::unixpath($inc) : $inc;
+ $full =~ s{/?$}{/};
+ $full .= $file;
+ $open = $self->_open_file($full, $file, $inc);
}
else {
- $self->{module} = $self->{packages}[0] || '';
+ $open = $self->_open_ref($inc, $file);
+ }
+ push @found, $open
+ if $open;
+ };
+ if (!$all) {
+ return $found[0]
+ if @found;
+ die $@
+ if $@;
+ }
+ }
+ croak "Can't locate $file"
+ if !$all;
+ return @found;
+ }
+
+ sub _open_file {
+ my ($self, $full, $file, $inc) = @_;
+ $file = $full
+ if !defined $file;
+ for my $try (
+ ($self->{pmc} && $file =~ /\.pm\z/ ? $full.'c' : ()),
+ $full,
+ ) {
+ my $pmc = $full ne $try;
+ if (-e $try) {
+ next
+ if -d _ || -b _;
+ if (open my $fh, '<'._OPEN_LAYERS, $try) {
+ return Module::Reader::File->new(
+ filename => $file,
+ ($self->{open} ? (raw_filehandle => $fh) : ()),
+ found_file => $full,
+ disk_file => $try,
+ is_pmc => $pmc,
+ (defined $inc ? (inc_entry => $inc) : ()),
+ );
}
}
- }
-
- $self->{version} = $self->{versions}{$self->{module}}
- if defined( $self->{module} );
-
- return $self;
- }
- # class method
- sub _do_find_module {
- my $class = shift;
- my $module = shift || croak 'find_module_by_name() requires a package name';
- my $dirs = shift || \@INC;
-
- my $file = File::Spec->catfile(split( /::/, $module));
- foreach my $dir ( @$dirs ) {
- my $testfile = File::Spec->catfile($dir, $file);
- return [ File::Spec->rel2abs( $testfile ), $dir ]
- if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
- $testfile .= '.pm';
- return [ File::Spec->rel2abs( $testfile ), $dir ]
- if -e $testfile;
+ croak "Can't locate $file: $full: $!"
+ if $self->{abort_on_eacces} && $! == EACCES && !$pmc;
}
return;
}
- # class method
- sub find_module_by_name {
- my $found = shift()->_do_find_module(@_) or return;
- return $found->[0];
- }
-
- # class method
- sub find_module_dir_by_name {
- my $found = shift()->_do_find_module(@_) or return;
- return $found->[1];
- }
-
+ sub _open_ref {
+ my ($self, $inc, $file) = @_;
- # given a line of perl code, attempt to parse it if it looks like a
- # $VERSION assignment, returning sigil, full name, & package name
- sub _parse_version_expression {
- my $self = shift;
- my $line = shift;
-
- my( $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/::$//;
- }
+ my @cb;
+ {
+ # strings in arrayrefs are taken as sub names relative to main
+ package
+ main;
+ no strict 'refs';
+ no warnings 'uninitialized';
+ @cb = defined Scalar::Util::blessed $inc ? $inc->INC($file)
+ : ref $inc eq 'ARRAY' ? $inc->[0]->($inc, $file)
+ : $inc->($inc, $file);
}
- return ( $sigil, $variable_name, $package );
- }
-
- # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
- # If there's one, then skip it and set the :encoding layer appropriately.
- sub _handle_bom {
- my ($self, $fh, $filename) = @_;
+ return
+ unless length ref $cb[0];
- my $pos = tell $fh;
- return unless defined $pos;
+ my $fake_file = sprintf _FAKE_FILE_FORMAT, refaddr($inc), $file;
- my $buf = ' ' x 2;
- my $count = read $fh, $buf, length $buf;
- return unless defined $count and $count >= 2;
+ my $fh;
+ my $prefix;
+ my $cb;
+ my $cb_options;
- 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 (_ALLOW_PREFIX && reftype $cb[0] eq 'SCALAR') {
+ $prefix = shift @cb;
}
- 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'" );
+ if ((reftype $cb[0]||'') eq 'GLOB' && openhandle $cb[0]) {
+ $fh = shift @cb;
}
- 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 );
-
- # From toke.c : any line that begins by "=X", where X is an alphabetic
- # character, introduces a POD segment.
- my $is_cut;
- if ( $line =~ /^=([a-zA-Z].*)/ ) {
- my $cmd = $1;
- # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
- # character (which includes the newline, but here we chomped it away).
- $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
- $in_pod = !$is_cut;
- }
-
- if ( $in_pod ) {
-
- if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
- push( @pod, $1 );
- if ( $self->{collect_pod} && length( $pod_data ) ) {
- $pod{$pod_sect} = $pod_data;
- $pod_data = '';
- }
- $pod_sect = $1;
-
- } elsif ( $self->{collect_pod} ) {
- $pod_data .= "$line\n";
-
- }
-
- } elsif ( $is_cut ) {
-
- if ( $self->{collect_pod} && length( $pod_data ) ) {
- $pod{$pod_sect} = $pod_data;
- $pod_data = '';
- }
- $pod_sect = '';
-
- } else {
-
- # Skip after __END__
- next if $in_end;
-
- # Skip comments in code
- next if $line =~ /^\s*#/;
-
- # Would be nice if we could also check $in_string or something too
- if ($line eq '__END__') {
- $in_end++;
- next;
- }
- last if $line eq '__DATA__';
-
- # parse $line to see if it's a $VERSION declaration
- my( $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 ){
- # 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 ( $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 );
- }
-
- # first non-comment line in undeclared package main is VERSION
- } 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 ( $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 ( $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 ((reftype $cb[0]||'') eq 'CODE') {
+ $cb = $cb[0];
+ # only one or zero callback options will be passed
+ $cb_options = @cb > 1 ? [ $cb[1] ] : undef;
}
-
- if ( $self->{collect_pod} && length($pod_data) ) {
- $pod{$pod_sect} = $pod_data;
+ elsif (!defined $fh && !defined $prefix) {
+ return;
}
-
- $self->{versions} = \%vers;
- $self->{packages} = \@packages;
- $self->{pod} = \%pod;
- $self->{pod_headings} = \@pod;
+ return Module::Reader::File->new(
+ filename => $file,
+ found_file => $fake_file,
+ inc_entry => $inc,
+ (defined $prefix ? (prefix => $prefix) : ()),
+ (defined $fh ? (raw_filehandle => $fh) : ()),
+ (defined $cb ? (read_callback => $cb) : ()),
+ (defined $cb_options ? (read_callback_options => $cb_options) : ()),
+ );
}
+ sub inc { $_[0]->{inc} }
+ sub found { $_[0]->{found} }
+ sub pmc { $_[0]->{pmc} }
+ sub open { $_[0]->{open} }
+
{
- my $pn = 0;
- sub _evaluate_version_line {
- my $self = shift;
- my( $sigil, $variable_name, $line ) = @_;
+ package Module::Reader::File;
+ use constant _OPEN_STRING => "$]" >= 5.008 || !require IO::String;
+ use Carp 'croak';
- # We compile into a local sub because 'use version' would cause
- # compiletime/runtime issues with local()
- $pn++; # everybody gets their own package
- my $eval = qq{ my \$dummy = q# Hide from _packages_inside()
- #; package Module::Metadata::_version::p${pn};
- use version;
- sub {
- local $sigil$variable_name;
- $line;
- \$$variable_name
+ sub new {
+ my ($class, %opts) = @_;
+ my $filename = $opts{filename};
+ if (!exists $opts{module} && $opts{filename}
+ && $opts{filename} =~ m{\A(\w+(?:/\w+)?)\.pm\z}) {
+ my $module = $1;
+ $module =~ s{/}{::}g;
+ $opts{module} = $module;
+ }
+ bless \%opts, $class;
+ }
+
+ sub filename { $_[0]->{filename} }
+ sub module { $_[0]->{module} }
+ sub found_file { $_[0]->{found_file} }
+ sub disk_file { $_[0]->{disk_file} }
+ sub is_pmc { $_[0]->{is_pmc} }
+ sub inc_entry { $_[0]->{inc_entry} }
+ sub read_callback { $_[0]->{read_callback} }
+ sub read_callback_options { $_[0]->{read_callback_options} }
+ sub raw_filehandle {
+ $_[0]->{raw_filehandle} ||= !$_[0]->{disk_file} ? undef : do {
+ open my $fh, '<'.Module::Reader::_OPEN_LAYERS, $_[0]->{disk_file}
+ or croak "Can't locate $_[0]->{disk_file}";
+ $fh;
};
- };
-
- $eval = $1 if $eval =~ m{^(.+)}s;
-
- local $^W;
- # Try to get the $VERSION
- my $vsub = __clean_eval($eval);
- # 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);
- $vsub = __clean_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->() };
- # 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!
-
- return $version;
- }
- }
-
- # Try to DWIM when things fail the lax version test in obvious ways
- {
- my @version_prep = (
- # Best case, it just works
- sub { return shift },
-
- # If we still don't have a version, try stripping any
- # trailing junk that is prohibited by lax rules
- sub {
- my $v = shift;
- $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
- return $v;
- },
-
- # Activestate apparently creates custom versions like '1.23_45_01', which
- # cause version.pm to think it's an invalid alpha. So check for that
- # and strip them
- sub {
- my $v = shift;
- my $num_dots = () = $v =~ m{(\.)}g;
- my $num_unders = () = $v =~ m{(_)}g;
- my $leading_v = substr($v,0,1) eq 'v';
- if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
- $v =~ s{_}{}g;
- $num_unders = () = $v =~ m{(_)}g;
- }
- return $v;
- },
-
- # Worst case, try numifying it like we would have before version objects
- sub {
- my $v = shift;
- no warnings 'numeric';
- return 0 + $v;
- },
-
- );
-
- sub _dwim_version {
- my ($result) = shift;
- return $result if ref($result) eq 'version';
-
- my ($version, $error);
- for my $f (@version_prep) {
- $result = $f->($result);
- $version = eval { version->new($result) };
- $error ||= $@ if $@; # capture first failure
- last if defined $version;
+ sub content {
+ my $self = shift;
+ return $self->{content}
+ if exists $self->{content};
+ my $fh = $self->raw_filehandle;
+ my $cb = $self->read_callback;
+ my $content = defined $self->{prefix} ? ${$self->{prefix}} : '';
+ if ($fh && !$cb) {
+ local $/;
+ $content .= <$fh>;
+ }
+ if ($cb) {
+ my @params = @{$self->read_callback_options||[]};
+ while (1) {
+ local $_ = $fh ? <$fh> : '';
+ $_ = ''
+ if !defined;
+ # perlfunc/require says that the first parameter will be a reference the
+ # sub itself. this is wrong. 0 will be passed.
+ last if !$cb->(0, @params);
+ $content .= $_;
+ }
}
-
- croak $error unless defined $version;
-
- return $version;
+ return $self->{content} = $content;
}
- }
-
- ############################################################
-
- # accessors
- sub name { $_[0]->{module} }
- sub filename { $_[0]->{filename} }
- sub packages_inside { @{$_[0]->{packages}} }
- sub pod_inside { @{$_[0]->{pod_headings}} }
- sub contains_pod { 0+@{$_[0]->{pod_headings}} }
-
- sub version {
+ sub handle {
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;
+ my $fh = $self->raw_filehandle;
+ if ($fh && !$self->read_callback && -f $fh) {
+ open my $dup, '<&', $fh
+ or croak "can't dup file handle: $!";
+ return $dup;
+ }
+ my $content = $self->content;
+ if (_OPEN_STRING) {
+ open my $fh, '<', \$content;
+ return $fh;
}
- }
-
- sub pod {
- my $self = shift;
- my $sect = shift;
- if ( defined( $sect ) && length( $sect ) &&
- exists( $self->{pod}{$sect} ) ) {
- return $self->{pod}{$sect};
- } else {
- return undef;
+ else {
+ return IO::String->new($content);
}
- }
-
- 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;
+ __END__
+
=head1 NAME
- Module::Metadata - Gather package and POD information from perl module files
+ Module::Reader - Find and read perl modules like perl does
=head1 SYNOPSIS
- use Module::Metadata;
+ use Module::Reader;
- # information about a .pm file
- my $info = Module::Metadata->new_from_file( $file );
- my $version = $info->version;
+ my $reader = Module::Reader->new;
+ my $module = $reader->module("My::Module");
+ my $filename = $module->found_file;
+ my $content = $module->content;
+ my $file_handle = $module->handle;
+
+ # search options
+ my $other_reader = Module::Reader->new(inc => ["/some/lib/dir", "/another/lib/dir"]);
+ my $other_reader2 = Module::Reader->new(found => { 'My/Module.pm' => '/a_location.pm' });
+
+ # Functional Interface
+ use Module::Reader qw(module_handle module_content);
+ my $io = module_handle('My::Module');
+ my $content = module_content('My::Module');
- # CPAN META 'provides' field for .pm files in a directory
- my $provides = Module::Metadata->provides(
- dir => 'lib', version => 2
- );
=head1 DESCRIPTION
- This module provides a standard way to gather metadata about a .pm file through
- (mostly) static analysis and (some) code execution. When determining the
- version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
- in the CPAN toolchain.
+ This module finds modules in C<@INC> using the same algorithm perl does. From
+ that, it will give you the source content of a module, the file name (where
+ available), and how it was found. Searches (and content) are based on the same
+ internal rules that perl uses for F<require|perlfunc/require> and
+ F<do|perlfunc/do>.
- =head1 CLASS METHODS
+ =head1 EXPORTS
- =head2 C<< new_from_file($filename, collect_pod => 1) >>
+ =head2 module_handle ( $module_name, @search_directories )
- Constructs a C<Module::Metadata> object given the path to a file. Returns
- undef if the filename does not exist.
+ Returns an IO handle for the given module.
- C<collect_pod> is a optional boolean argument that determines whether POD
- data is collected and stored for reference. POD data is not collected by
- default. POD headings are always collected.
+ =head2 module_content ( $module_name, @search_directories )
- If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
- it is skipped before processing, and the content of the file is also decoded
- appropriately starting from perl 5.8.
+ Returns the content of a given module.
- =head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >>
+ =head1 ATTRIBUTES
- This works just like C<new_from_file>, except that a handle can be provided
- as the first argument.
+ =over 4
- Note that there is no validation to confirm that the handle is a handle or
- something that can act like one. Passing something that isn't a handle will
- cause a exception when trying to read from it. The C<filename> argument is
- mandatory or undef will be returned.
+ =item inc
- You are responsible for setting the decoding layers on C<$handle> if
- required.
+ An array reference containing a list of directories or hooks to search for
+ modules or files. This will be used in the same manner that
+ L<require|perlfunc/require> uses L<< C<@INC>|perlvar/@INC >>. If not provided,
+ L<< C<@INC>|perlvar/@INC >> itself will be used.
- =head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
+ =item found
- Constructs a C<Module::Metadata> object given a module or package name.
- Returns undef if the module cannot be found.
+ A hash reference of module filenames (of C<My/Module.pm> format>) to files that
+ exist on disk, working the same as L<< C<%INC>|perlvar/%INC >>. The values can
+ optionally be an L<< C<@INC> hook|perlfunc/require >>. This option can also be
+ 1, in which case L<< C<%INC>|perlfunc/%INC >> will be used instead.
- In addition to accepting the C<collect_pod> argument as described above,
- this method accepts a C<inc> argument which is a reference to an array of
- directories to search for the module. If none are given, the default is
- @INC.
+ =item pmc
- If the file that contains the module begins by an UTF-8, UTF-16BE or
- UTF-16LE byte-order mark, then it is skipped before processing, and the
- content of the file is also decoded appropriately starting from perl 5.8.
+ A boolean controlling if C<.pmc> files should be found in preference to C<.pm>
+ files. If not specified, the same behavior perl was compiled with will be used.
- =head2 C<< find_module_by_name($module, \@dirs) >>
+ =item open
- Returns the path to a module given the module or package name. A list
- of directories can be passed in as an optional parameter, otherwise
- @INC is searched.
+ A boolean controlling if the files found will be opened immediately when found.
+ Defaults to true.
- Can be called as either an object or a class method.
+ =item abort_on_eacces
- =head2 C<< find_module_dir_by_name($module, \@dirs) >>
+ A boolean controlling if an error should be thrown or if the path should be
+ skipped when encountering C<EACCES> (access denied) errors. Defaults to true
+ on perl 5.18 and above, matching the behavior of L<require|perlfunc/require>.
- Returns the entry in C<@dirs> (or C<@INC> by default) that contains
- the module C<$module>. A list of directories can be passed in as an
- optional parameter, otherwise @INC is searched.
+ =item check_hooks_for_nonsearchable
- Can be called as either an object or a class method.
+ For non-searchable paths (absolute paths and those starting with C<./> or
+ C<../>) attempt to check the hook items (and not the directories) in C<@INC> if
+ the file cannot be found directly. This matches the behavior of perl. Defaults
+ to true.
- =head2 C<< provides( %options ) >>
+ =back
- This is a convenience wrapper around C<package_versions_from_directory>
- to generate a CPAN META C<provides> data structure. It takes key/value
- pairs. Valid option keys include:
+ =head1 METHODS
- =over
+ =head2 module
- =item version B<(required)>
+ Returns a L<file object|/FILE OBJECTS> for the given module name. If the module
+ can't be found, an exception will be raised.
- Specifies which version of the L<CPAN::Meta::Spec> should be used as
- the format of the C<provides> output. Currently only '1.4' and '2'
- are supported (and their format is identical). This may change in
- the future as the definition of C<provides> changes.
+ =head2 file
- The C<version> option is required. If it is omitted or if
- an unsupported version is given, then C<provides> will throw an error.
+ Returns a L<file object|/FILE OBJECTS> for the given file name. If the file
+ can't be found, an exception will be raised. For absolute paths, or files
+ starting with C<./> or C<../> (and C<.\> or C<..\> on Windows), no directory
+ search will be performed.
- =item dir
+ =head2 modules
- Directory to search recursively for F<.pm> files. May not be specified with
- C<files>.
+ Returns an array of L<file objects|/FILE OBJECTS> for a given module name. This
+ will give every file that could be loaded based on the L</inc> options.
- =item files
+ =head2 files
- Array reference of files to examine. May not be specified with C<dir>.
+ Returns an array of L<file objects|/FILE OBJECTS> for a given file name. This
+ will give every file that could be loaded based on the L</inc> options.
- =item prefix
+ =head1 FILE OBJECTS
- String to prepend to the C<file> field of the resulting output. This defaults
- to F<lib>, which is the common case for most CPAN distributions with their
- F<.pm> files in F<lib>. This option ensures the META information has the
- correct relative path even when the C<dir> or C<files> arguments are
- absolute or have relative paths from a location other than the distribution
- root.
+ The file objects returned represent an entry that could be found in
+ L<< C<@INC>|perlvar/@INC >>. While they will generally be files that exist on
+ the file system somewhere, they may also represent files that only exist only in
+ memory or have arbitrary filters applied.
- =back
+ =head2 FILE METHODS
- For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
- is a hashref of the form:
+ =head3 filename
- {
- 'Package::Name' => {
- version => '0.123',
- file => 'lib/Package/Name.pm'
- },
- 'OtherPackage::Name' => ...
- }
+ The filename that was searched for.
- =head2 C<< package_versions_from_directory($dir, \@files?) >>
+ =head3 module
- Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
- for those files in C<$dir> - and reads each file for packages and versions,
- returning a hashref of the form:
+ If a module was searched for, or a file of the matching form (C<My/Module.pm>),
+ this will be the module searched for.
- {
- 'Package::Name' => {
- version => '0.123',
- file => 'Package/Name.pm'
- },
- 'OtherPackage::Name' => ...
- }
+ =head3 found_file
- The C<DB> and C<main> packages are always omitted, as are any "private"
- packages that have leading underscores in the namespace (e.g.
- C<Foo::_private>)
+ The path to the file found by L<require|perlfunc/require>.
- Note that the file path is relative to C<$dir> if that is specified.
- This B<must not> be used directly for CPAN META C<provides>. See
- the C<provides> method instead.
+ This may not represent an actual file that exists, but the file name that perl
+ will use for the file for things like L<caller|perlfunc/caller> or
+ L<__FILE__|perlfunc/__FILE__>.
- =head2 C<< log_info (internal) >>
+ For C<.pmc> files, this will be the C<.pm> form of the file.
- Used internally to perform logging; imported from Log::Contextual if
- Log::Contextual has already been loaded, otherwise simply calls warn.
+ For L<< C<@INC> hooks|perlfunc/require >> this will be a file name of the form
+ C</loader/0x123456abcdef/My/Module.pm>, matching how perl treats them internally.
- =head1 OBJECT METHODS
+ =head3 disk_file
- =head2 C<< name() >>
+ The path to the file that exists on disk. When the file is found via an
+ L<< C<@INC> hook|perlfunc/require >>, this will be undef.
- Returns the name of the package represented by this module. If there
- 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'.
+ =head3 content
- =head2 C<< version($package) >>
+ The content of the found file.
- Returns the version as defined by the $VERSION variable for the
- package as returned by the C<name> method if no arguments are
- given. If given the name of a package it will attempt to return the
- version of that package if it is specified in the file.
+ =head3 handle
- =head2 C<< filename() >>
+ A file handle to the found file's content.
- Returns the absolute path to the file.
- Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle.
+ =head3 is_pmc
- =head2 C<< packages_inside() >>
+ A boolean value representing if the file found was C<.pmc> variant of the file
+ requested.
- Returns a list of packages. Note: this is a raw list of packages
- discovered (or assumed, in the case of C<main>). It is not
- filtered for C<DB>, C<main> or private packages the way the
- C<provides> method does. Invalid package names are not returned,
- for example "Foo:Bar". Strange but valid package names are
- returned, for example "Foo::Bar::", and are left up to the caller
- on how to handle.
+ =head3 inc_entry
- =head2 C<< pod_inside() >>
+ The directory or L<hook|perlfunc/require> that was used to find the given file
+ or module. If L</found> is used, this may be undef.
- Returns a list of POD sections.
+ =head2 RAW HOOK DATA
- =head2 C<< contains_pod() >>
+ File objects also have methods for the raw file handle and read callbacks used
+ to read a file. Interacting with the handle or callback can impact the return
+ values of L</content> and L</handle>, and vice versa. It should generally be
+ avoided unless you are introspecting the F<< C<@INC> hooks|perlfunc/require >>.
- Returns true if there is any POD in the file.
+ =head3 raw_filehandle
- =head2 C<< pod($section) >>
+ The raw file handle to the file found. This will be either a file handle to a
+ file found on disk, or something returned by an
+ F<< C<@INC> hook|perlfunc/require >>. The hook callback, if it exists, will not
+ be taken into account by this method.
- Returns the POD data in the given section.
+ =head3 read_callback
- =head2 C<< is_indexable($package) >> or C<< is_indexable() >>
+ A callback used to read content, or modify a file handle from an C<@INC> hook.
- 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.
+ =head3 read_callback_options
- =head1 AUTHOR
+ An array reference of arguments to send to the read callback whem reading or
+ modifying content from a file handle. Will contain either zero or one entries.
- Original code from Module::Build::ModuleInfo by Ken Williams
- <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
+ =head1 SEE ALSO
- Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
- assistance from David Golden (xdg) <dagolden@cpan.org>.
+ Numerous other modules attempt to do C<@INC> searches similar to this module,
+ but no other module accurately represents how perl itself uses
+ L<< C<@INC>|perlvar/@INC >>. Most don't match perl's behavior regarding
+ character and block devices, directories, or permissions. Often, C<.pmc> files
+ are not taken into account.
- =head1 COPYRIGHT & LICENSE
+ Some of these modules have other use cases. The following comments are
+ primarily related to their ability to search C<@INC>.
- Original code Copyright (c) 2001-2011 Ken Williams.
- Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
- All rights reserved.
+ =over 4
- This library is free software; you can redistribute it and/or
- modify it under the same terms as Perl itself.
+ =item L<App::moduleswhere>
- =cut
-MODULE_METADATA
-
-$fatpacked{"Module/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_READER';
- package Module::Reader;
- BEGIN { require 5.006 }
- use strict;
- use warnings;
+ Only available as a command line utility. Inaccurately gives the first file
+ found on disk in C<@INC>.
- our $VERSION = '0.002003';
- $VERSION = eval $VERSION;
+ =item L<App::whichpm>
- use base 'Exporter';
- our @EXPORT_OK = qw(module_content module_handle);
- our %EXPORT_TAGS = (all => [@EXPORT_OK]);
+ Inaccurately gives the first file found on disk in C<@INC>.
- use File::Spec;
- use Scalar::Util qw(blessed reftype openhandle);
- use Carp;
- use constant _OPEN_STRING => $] >= 5.008;
- BEGIN {
- require IO::String
- if !_OPEN_STRING;
- }
+ =item L<Class::Inspector>
- sub module_content {
- my $module = _get_module(@_);
- if (ref $module) {
- local $/;
- return scalar <$module>;
- }
- else {
- return $module;
- }
- }
+ For unloaded modules, inaccurately checks if a module exists.
- sub module_handle {
- my $module = _get_module(@_);
- if (ref $module) {
- return $module;
- }
- elsif (_OPEN_STRING) {
- open my $fh, '<', \$module;
- return $fh;
- }
- else {
- return IO::String->new($module);
- }
- }
+ =item L<Module::Data>
- sub _get_module {
- my ($package, @inc) = @_;
- (my $module = "$package.pm") =~ s{::}{/}g;
- my $opts = ref $_[-1] && ref $_[-1] eq 'HASH' && pop @inc || {};
- if (!@inc) {
- @inc = @INC;
- }
- if (my $found = $opts->{found}) {
- if (my $full_module = $found->{$module}) {
- if (ref $full_module) {
- @inc = $full_module;
- }
- elsif (-f $full_module) {
- open my $fh, '<', $full_module
- or die "Couldn't open ${full_module} for ${module}: $!";
- return $fh;
- }
- }
- }
- for my $inc (@inc) {
- if (!ref $inc) {
- my $full_module = File::Spec->catfile($inc, $module);
- next unless -f $full_module;
- open my $fh, '<', $full_module
- or die "Couldn't open ${full_module} for ${module}: $!";
- return $fh;
- }
+ Same caveats as L</Path::ScanINC>.
- my @cb = ref $inc eq 'ARRAY' ? $inc->[0]->($inc, $module)
- : blessed $inc ? $inc->INC($module)
- : $inc->($inc, $module);
+ =item L<Module::Filename>
- next
- unless ref $cb[0];
- my $fh;
- if (reftype $cb[0] eq 'GLOB' && openhandle $cb[0]) {
- $fh = shift @cb;
- }
+ Inaccurately gives the first file found on disk in C<@INC>.
- if (ref $cb[0] eq 'CODE') {
- my $cb = shift @cb;
- # require docs are wrong, perl sends 0 as the first param
- my @params = (0, @cb ? $cb[0] : ());
-
- my $module = '';
- while (1) {
- local $_ = $fh ? <$fh> : '';
- $_ = ''
- if !defined;
- last if !$cb->(@params);
- $module .= $_;
- }
- return $module;
- }
- elsif ($fh) {
- return $fh;
- }
- }
- croak "Can't find module $module";
- }
+ =item L<Module::Finder>
- 1;
+ Inaccurately searches for C<.pm> and C<.pmc> files in subdirectories of C<@INC>.
- __END__
+ =item L<Module::Info>
- =head1 NAME
+ Inaccurately searches C<@INC> for files and gives inaccurate information for the
+ files that it finds.
- Module::Reader - Read the source of a module like perl does
+ =item L<Module::Locate>
- =head1 SYNOPSIS
+ Inaccurately searches C<@INC> for matching files. Attempts to handle hooks, but
+ handles most cases wrong.
- use Module::Reader qw(:all);
- my $io = module_handle('My::Module');
- my $content = module_content('My::Module');
-
- my $io = module_handle('My::Module', @search_dirs);
-
- my $io = module_handle('My::Module', @search_dirs, { found => \%INC });
+ =item L<Module::Mapper>
- =head1 DESCRIPTION
+ Searches for C<.pm> and C<.pod> files in relatively unpredictable fashion,
+ based usually on the current directory. Optionally, can inaccurately scan
+ C<@INC>.
- Reads the content of perl modules the same way perl does. This
- includes reading modules available only by L<@INC hooks|perlfunc/require>, or filtered
- through them.
+ =item L<Module::Metadata>
- =head1 EXPORTS
+ Primarily designed as a version number extractor. Meant to find files on disk,
+ avoiding the nuance involved in perl's file loading.
- =head2 module_handle( $module_name, @search_dirs, \%options )
+ =item L<Module::Path>
- Returns an IO handle to the given module. Searches the directories
- specified, or L<@INC|perlvar/@INC> if none are.
+ Inaccurately gives the first file found on disk in C<@INC>.
- =head3 Options
+ =item L<Module::Util>
- =over 4
+ Inaccurately searches for modules, ignoring C<@INC> hooks.
- =item found
+ =item L<Path::ScanINC>
- A reference to a hash like L<%INC|perlvar/%INC> with module file names (in the
- style 'F<My/Module.pm>') as keys and full file paths as values.
- Modules listed in this will be used in preference to searching
- through directories.
+ Inaccurately searches for files, with confusing output for C<@INC> hooks.
- =back
+ =item L<Pod::Perldoc>
- =head2 module_content( $module_name, @search_dirs, \%options )
+ Primarily meant for searching for related documentation. Finds related module
+ files, or sometimes C<.pod> files. Unpredictable search path.
- Returns the content of the given module. Accepts the same options as C<module_handle>.
+ =back
=head1 AUTHOR
@@ -68744,12 +70113,12 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
package Path::Tiny;
# ABSTRACT: File path utility
- our $VERSION = '0.072'; # from Path-Tiny-0.072.tar.gz
+ our $VERSION = '0.104';
# Dependencies
use Config;
use Exporter 5.57 (qw/import/);
- use File::Spec 3.40 ();
+ use File::Spec 0.86 (); # shipped with 5.8.1
use Carp ();
our @EXPORT = qw/path/;
@@ -68783,6 +70152,12 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
!!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1 };
}
+ my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
+
+ sub _check_PU {
+ !!eval { require PerlIO::utf8_strict; PerlIO::utf8_strict->VERSION(0.003); 1 };
+ }
+
my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
@@ -68812,6 +70187,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT$/ ) : ( $_[0] eq '/' );
}
+ BEGIN {
+ *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
+ }
+
# mode bits encoded for chmod in symbolic mode
my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
{ my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };
@@ -68851,7 +70230,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
my $WARNED_BSD_NFS = 0;
sub _throw {
- my ( $self, $function, $file ) = @_;
+ my ( $self, $function, $file, $msg ) = @_;
if ( IS_BSD()
&& $function =~ /^flock/
&& $! =~ /operation not supported/i
@@ -68863,7 +70242,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
}
}
else {
- Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ), $! );
+ $msg = $! unless defined $msg;
+ Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
+ $msg );
}
return;
}
@@ -68962,6 +70343,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
# canonicalize, but with unix slashes and put back trailing volume slash
my $cpath = $path = File::Spec->canonpath($path);
$path =~ tr[\\][/] if IS_WIN32();
+ $path = "/" if $path eq '/..'; # for old File::Spec
$path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL$};
# root paths must always have a trailing slash, but other paths must not
@@ -68976,6 +70358,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
if ( $path =~ m{^(~[^/]*).*} ) {
require File::Glob;
my ($homedir) = File::Glob::bsd_glob($1);
+ $homedir =~ tr[\\][/] if IS_WIN32();
$path =~ s{^(~[^/]*)}{$homedir};
}
@@ -69054,7 +70437,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
#pod
#pod The tempfile path object will be normalized to have an absolute path, even if
- #pod created in a relative directory using C<DIR>.
+ #pod created in a relative directory using C<DIR>. If you want it to have
+ #pod the C<realpath> instead, pass a leading options hash like this:
+ #pod
+ #pod $real_temp = tempfile({realpath => 1}, @options);
#pod
#pod C<tempdir> is just like C<tempfile>, except it calls
#pod C<< File::Temp->newdir >> instead.
@@ -69068,12 +70454,29 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
#pod up.
#pod
- #pod Current API available since 0.018.
+ #pod B<Note 2>: if you don't want these cleaned up automatically when the object
+ #pod is destroyed, File::Temp requires different options for directories and
+ #pod files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
+ #pod files.
+ #pod
+ #pod B<Note 3>: Don't lose the temporary object by chaining a method call instead
+ #pod of storing it:
+ #pod
+ #pod my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
+ #pod
+ #pod B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
+ #pod Keeping a reference to, or modifying the cached object may break the
+ #pod behavior documented above and is not supported. Use at your own risk.
+ #pod
+ #pod Current API available since 0.097.
#pod
#pod =cut
sub tempfile {
shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
+ my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
+ $opts = _get_args( $opts, qw/realpath/ );
+
my ( $maybe_template, $args ) = _parse_file_temp_args(@_);
# File::Temp->new demands TEMPLATE
$args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
@@ -69081,19 +70484,22 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
require File::Temp;
my $temp = File::Temp->new( TMPDIR => 1, %$args );
close $temp;
- my $self = path($temp)->absolute;
+ my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
$self->[TEMP] = $temp; # keep object alive while we are
return $self;
}
sub tempdir {
shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
+ my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
+ $opts = _get_args( $opts, qw/realpath/ );
+
my ( $maybe_template, $args ) = _parse_file_temp_args(@_);
# File::Temp->newdir demands leading template
require File::Temp;
my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
- my $self = path($temp)->absolute;
+ my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
$self->[TEMP] = $temp; # keep object alive while we are
# Some ActiveState Perls for Windows break Cwd in ways that lead
# File::Temp to get confused about what path to remove; this
@@ -69124,6 +70530,24 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
@{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
}
+ sub _resolve_symlinks {
+ my ($self) = @_;
+ my $new = $self;
+ my ( $count, %seen ) = 0;
+ while ( -l $new->[PATH] ) {
+ if ( $seen{ $new->[PATH] }++ ) {
+ $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
+ }
+ if ( ++$count > 100 ) {
+ $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
+ }
+ my $resolved = readlink $new->[PATH] or $new->_throw( 'readlink', $new->[PATH] );
+ $resolved = path($resolved);
+ $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
+ }
+ return $new;
+ }
+
#--------------------------------------------------------------------------#
# Public methods
#--------------------------------------------------------------------------#
@@ -69134,9 +70558,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod $abs = path("foo/bar")->absolute("/tmp");
#pod
#pod Returns a new C<Path::Tiny> object with an absolute path (or itself if already
- #pod absolute). Unless an argument is given, the current directory is used as the
- #pod absolute base path. The argument must be absolute or you won't get an absolute
- #pod result.
+ #pod absolute). If no argument is given, the current directory is used as the
+ #pod absolute base path. If an argument is given, it will be converted to an
+ #pod absolute path (if it is not already) and used as the absolute base path.
#pod
#pod This will not resolve upward directories ("foo/../bar") unless C<canonpath>
#pod in L<File::Spec> would normally do so on your platform. If you need them
@@ -69145,7 +70569,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod On Windows, an absolute path without a volume component will have it added
#pod based on the current drive.
#pod
- #pod Current API available since 0.001.
+ #pod Current API available since 0.101.
#pod
#pod =cut
@@ -69168,9 +70592,15 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
return $self if $self->is_absolute;
}
- # relative path on any OS
+ # no base means use current directory as base
require Cwd;
- return path( ( defined($base) ? $base : Cwd::getcwd() ), $_[0]->[PATH] );
+ return path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;
+
+ # relative base should be made absolute; we check is_absolute rather
+ # than unconditionally make base absolute so that "/foo" doesn't become
+ # "C:/foo" on Windows.
+ $base = path($base);
+ return path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] );
}
#pod =method append, append_raw, append_utf8
@@ -69196,8 +70626,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod unbuffered, raw write.
#pod
#pod C<append_utf8> is like C<append> with a C<binmode> of
- #pod C<:unix:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
- #pod append will be done instead on the data encoded with C<Unicode::UTF8>.
+ #pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+ #pod 0.58+ is installed, a raw append will be done instead on the data encoded
+ #pod with C<Unicode::UTF8>.
#pod
#pod Current API available since 0.060.
#pod
@@ -69231,6 +70662,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$args->{binmode} = ":unix";
append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
}
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $args->{binmode} = ":unix:utf8_strict";
+ append( $self, $args, @data );
+ }
else {
$args->{binmode} = ":unix:encoding(UTF-8)";
append( $self, $args, @data );
@@ -69308,6 +70743,27 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
sub canonpath { $_[0]->[CANON] }
+ #pod =method cached_temp
+ #pod
+ #pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
+ #pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
+ #pod If there is no such object, this method throws.
+ #pod
+ #pod B<WARNING>: Keeping a reference to, or modifying the cached object may
+ #pod break the behavior documented for temporary files and directories created
+ #pod with C<Path::Tiny> and is not supported. Use at your own risk.
+ #pod
+ #pod Current API available since 0.101.
+ #pod
+ #pod =cut
+
+ sub cached_temp {
+ my $self = shift;
+ $self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
+ unless defined $self->[TEMP];
+ return $self->[TEMP];
+ }
+
#pod =method child
#pod
#pod $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
@@ -69409,9 +70865,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod
#pod path("/tmp/foo.txt")->copy("/tmp/bar.txt");
#pod
- #pod Copies a file using L<File::Copy>'s C<copy> function. Upon
- #pod success, returns the C<Path::Tiny> object for the newly copied
- #pod file.
+ #pod Copies the current path to the given destination using L<File::Copy>'s
+ #pod C<copy> function. Upon success, returns the C<Path::Tiny> object for the
+ #pod newly copied file.
#pod
#pod Current API available since 0.070.
#pod
@@ -69486,6 +70942,120 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
return length $self->[DIR] ? $self->[DIR] : ".";
}
+ #pod =method edit, edit_raw, edit_utf8
+ #pod
+ #pod path("foo.txt")->edit( \&callback, $options );
+ #pod path("foo.txt")->edit_utf8( \&callback );
+ #pod path("foo.txt")->edit_raw( \&callback );
+ #pod
+ #pod These are convenience methods that allow "editing" a file using a single
+ #pod callback argument. They slurp the file using C<slurp>, place the contents
+ #pod inside a localized C<$_> variable, call the callback function (without
+ #pod arguments), and then write C<$_> (presumably mutated) back to the
+ #pod file with C<spew>.
+ #pod
+ #pod An optional hash reference may be used to pass options. The only option is
+ #pod C<binmode>, which is passed to C<slurp> and C<spew>.
+ #pod
+ #pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
+ #pod C<spew_*> methods.
+ #pod
+ #pod Current API available since 0.077.
+ #pod
+ #pod =cut
+
+ sub edit {
+ my $self = shift;
+ my $cb = shift;
+ my $args = _get_args( shift, qw/binmode/ );
+ Carp::croak("Callback for edit() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ local $_ =
+ $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
+ $cb->();
+ $self->spew( $args, $_ );
+
+ return;
+ }
+
+ # this is done long-hand to benefit from slurp_utf8 optimizations
+ sub edit_utf8 {
+ my ( $self, $cb ) = @_;
+ Carp::croak("Callback for edit_utf8() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ local $_ = $self->slurp_utf8;
+ $cb->();
+ $self->spew_utf8($_);
+
+ return;
+ }
+
+ sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
+
+ #pod =method edit_lines, edit_lines_utf8, edit_lines_raw
+ #pod
+ #pod path("foo.txt")->edit_lines( \&callback, $options );
+ #pod path("foo.txt")->edit_lines_utf8( \&callback );
+ #pod path("foo.txt")->edit_lines_raw( \&callback );
+ #pod
+ #pod These are convenience methods that allow "editing" a file's lines using a
+ #pod single callback argument. They iterate over the file: for each line, the
+ #pod line is put into a localized C<$_> variable, the callback function is
+ #pod executed (without arguments) and then C<$_> is written to a temporary file.
+ #pod When iteration is finished, the temporary file is atomically renamed over
+ #pod the original.
+ #pod
+ #pod An optional hash reference may be used to pass options. The only option is
+ #pod C<binmode>, which is passed to the method that open handles for reading and
+ #pod writing.
+ #pod
+ #pod C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
+ #pod C<slurp_*> and C<spew_*> methods.
+ #pod
+ #pod Current API available since 0.077.
+ #pod
+ #pod =cut
+
+ sub edit_lines {
+ my $self = shift;
+ my $cb = shift;
+ my $args = _get_args( shift, qw/binmode/ );
+ Carp::croak("Callback for edit_lines() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ my $binmode = $args->{binmode};
+ # get default binmode from caller's lexical scope (see "perldoc open")
+ $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
+
+ # writing need to follow the link and create the tempfile in the same
+ # dir for later atomic rename
+ my $resolved_path = $self->_resolve_symlinks;
+ my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) );
+
+ my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
+ my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
+
+ local $_;
+ while (<$in_fh>) {
+ $cb->();
+ $temp_fh->print($_);
+ }
+
+ close $temp_fh or $self->_throw( 'close', $temp );
+ close $in_fh or $self->_throw('close');
+
+ return $temp->move($resolved_path);
+ }
+
+ sub edit_lines_raw { $_[2] = { binmode => ":unix" }; goto &edit_lines }
+
+ sub edit_lines_utf8 {
+ $_[2] = { binmode => ":raw:encoding(UTF-8)" };
+ goto &edit_lines;
+ }
+
#pod =method exists, is_file, is_dir
#pod
#pod if ( path("/tmp")->exists ) { ... } # -e
@@ -69518,7 +71088,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode);
#pod
#pod Returns an open file handle. The C<$mode> argument must be a Perl-style
- #pod read/write mode string ("<" ,">", "<<", etc.). If a C<$binmode>
+ #pod read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode>
#pod is given, it is set during the C<open> call.
#pod
#pod An optional hash reference may be used to pass options.
@@ -69764,8 +71334,8 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw>
#pod instead of C<:unix> so PerlIO buffering can manage reading by line.
#pod
- #pod C<lines_utf8> is like C<lines> with a C<binmode> of
- #pod C<:raw:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
+ #pod C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
+ #pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
#pod UTF-8 slurp will be done and then the lines will be split. This is
#pod actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
#pod intensive. If memory use is a concern, consider C<openr_utf8> and
@@ -69818,6 +71388,8 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
}
}
+ my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/;
+
sub lines_utf8 {
my $self = shift;
my $args = _get_args( shift, qw/binmode chomp count/ );
@@ -69825,7 +71397,13 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
&& $args->{chomp}
&& !$args->{count} )
{
- return split /(?:\x{0d}?\x{0a}|\x{0d})/, slurp_utf8($self); ## no critic
+ my $slurp = slurp_utf8($self);
+ $slurp =~ s/$CRLF$//; # like chomp, but full CR?LF|CR
+ return split $CRLF, $slurp, -1; ## no critic
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $args->{binmode} = ":unix:utf8_strict";
+ return lines( $self, $args );
}
else {
$args->{binmode} = ":raw:encoding(UTF-8)";
@@ -69865,7 +71443,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod
#pod path("foo.txt")->move("bar.txt");
#pod
- #pod Just like C<rename>.
+ #pod Move the current path to the given destination path using Perl's
+ #pod built-in L<rename|perlfunc/rename> function. Returns the result
+ #pod of the C<rename> function.
#pod
#pod Current API available since 0.001.
#pod
@@ -70032,6 +71612,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
# doesn't throw an error resolving non-existent basename
sub realpath {
my $self = shift;
+ $self = $self->_resolve_symlinks;
require Cwd;
$self->_splitpath if !defined $self->[FILE];
my $check_parent =
@@ -70051,16 +71632,139 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod
#pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
#pod
- #pod Returns a C<Path::Tiny> object with a relative path name.
- #pod Given the trickiness of this, it's a thin wrapper around
- #pod C<< File::Spec->abs2rel() >>.
+ #pod Returns a C<Path::Tiny> object with a path relative to a new base path
+ #pod given as an argument. If no argument is given, the current directory will
+ #pod be used as the new base path.
#pod
- #pod Current API available since 0.001.
+ #pod If either path is already relative, it will be made absolute based on the
+ #pod current directly before determining the new relative path.
+ #pod
+ #pod The algorithm is roughly as follows:
+ #pod
+ #pod =for :list
+ #pod * If the original and new base path are on different volumes, an exception
+ #pod will be thrown.
+ #pod * If the original and new base are identical, the relative path is C<".">.
+ #pod * If the new base subsumes the original, the relative path is the original
+ #pod path with the new base chopped off the front
+ #pod * If the new base does not subsume the original, a common prefix path is
+ #pod determined (possibly the root directory) and the relative path will
+ #pod consist of updirs (C<"..">) to reach the common prefix, followed by the
+ #pod original path less the common prefix.
+ #pod
+ #pod Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
+ #pod on a common prefix takes into account symlinks that could affect the updir
+ #pod process. Given an original path "/A/B" and a new base "/A/C",
+ #pod (where "A", "B" and "C" could each have multiple path components):
+ #pod
+ #pod =for :list
+ #pod * Symlinks in "A" don't change the result unless the last component of A is
+ #pod a symlink and the first component of "C" is an updir.
+ #pod * Symlinks in "B" don't change the result and will exist in the result as
+ #pod given.
+ #pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
+ #pod account the possibility that not all path components might exist on the
+ #pod filesystem.
+ #pod
+ #pod Current API available since 0.001. New algorithm (that accounts for
+ #pod symlinks) available since 0.079.
#pod
#pod =cut
- # Easy to get wrong, so wash it through File::Spec (sigh)
- sub relative { path( File::Spec->abs2rel( $_[0]->[PATH], $_[1] ) ) }
+ sub relative {
+ my ( $self, $base ) = @_;
+ $base = path( defined $base && length $base ? $base : '.' );
+
+ # relative paths must be converted to absolute first
+ $self = $self->absolute if $self->is_relative;
+ $base = $base->absolute if $base->is_relative;
+
+ # normalize volumes if they exist
+ $self = $self->absolute if !length $self->volume && length $base->volume;
+ $base = $base->absolute if length $self->volume && !length $base->volume;
+
+ # can't make paths relative across volumes
+ if ( !_same( $self->volume, $base->volume ) ) {
+ Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
+ }
+
+ # if same absolute path, relative is current directory
+ return path(".") if _same( $self->[PATH], $base->[PATH] );
+
+ # if base is a prefix of self, chop prefix off self
+ if ( $base->subsumes($self) ) {
+ $base = "" if $base->is_rootdir;
+ my $relative = "$self";
+ $relative =~ s{\A\Q$base/}{};
+ return path($relative);
+ }
+
+ # base is not a prefix, so must find a common prefix (even if root)
+ my ( @common, @self_parts, @base_parts );
+ @base_parts = split /\//, $base->_just_filepath;
+
+ # if self is rootdir, then common directory is root (shown as empty
+ # string for later joins); otherwise, must be computed from path parts.
+ if ( $self->is_rootdir ) {
+ @common = ("");
+ shift @base_parts;
+ }
+ else {
+ @self_parts = split /\//, $self->_just_filepath;
+
+ while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
+ push @common, shift @base_parts;
+ shift @self_parts;
+ }
+ }
+
+ # if there are any symlinks from common to base, we have a problem, as
+ # you can't guarantee that updir from base reaches the common prefix;
+ # we must resolve symlinks and try again; likewise, any updirs are
+ # a problem as it throws off calculation of updirs needed to get from
+ # self's path to the common prefix.
+ if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
+ return $self->relative($new_base);
+ }
+
+ # otherwise, symlinks in common or from common to A don't matter as
+ # those don't involve updirs
+ my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
+ return path(@new_path);
+ }
+
+ sub _just_filepath {
+ my $self = shift;
+ my $self_vol = $self->volume;
+ return "$self" if !length $self_vol;
+
+ ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
+
+ return $self_path;
+ }
+
+ sub _resolve_between {
+ my ( $self, $common, $base ) = @_;
+ my $path = $self->volume . join( "/", @$common );
+ my $changed = 0;
+ for my $p (@$base) {
+ $path .= "/$p";
+ if ( $p eq '..' ) {
+ $changed = 1;
+ if ( -e $path ) {
+ $path = path($path)->realpath->[PATH];
+ }
+ else {
+ $path =~ s{/[^/]+/..$}{/};
+ }
+ }
+ if ( -l $path ) {
+ $changed = 1;
+ $path = path($path)->realpath->[PATH];
+ }
+ }
+ return $changed ? path($path) : undef;
+ }
#pod =method remove
#pod
@@ -70145,18 +71849,18 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod $data = path("foo.txt")->slurp_raw;
#pod $data = path("foo.txt")->slurp_utf8;
#pod
- #pod Reads file contents into a scalar. Takes an optional hash reference may be
- #pod used to pass options. The only option is C<binmode>, which is passed to
- #pod C<binmode()> on the handle used for reading.
+ #pod Reads file contents into a scalar. Takes an optional hash reference which may
+ #pod be used to pass options. The only available option is C<binmode>, which is
+ #pod passed to C<binmode()> on the handle used for reading.
#pod
#pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
#pod a fast, unbuffered, raw read.
#pod
#pod C<slurp_utf8> is like C<slurp> with a C<binmode> of
- #pod C<:unix:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
- #pod slurp will be done instead and the result decoded with C<Unicode::UTF8>.
- #pod This is just as strict and is roughly an order of magnitude faster than
- #pod using C<:encoding(UTF-8)>.
+ #pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+ #pod 0.58+ is installed, a raw slurp will be done instead and the result decoded
+ #pod with C<Unicode::UTF8>. This is just as strict and is roughly an order of
+ #pod magnitude faster than using C<:encoding(UTF-8)>.
#pod
#pod B<Note>: C<slurp> and friends lock the filehandle before slurping. If
#pod you plan to slurp from a file created with L<File::Temp>, be sure to
@@ -70194,6 +71898,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
}
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $_[1] = { binmode => ":unix:utf8_strict" };
+ goto &slurp;
+ }
else {
$_[1] = { binmode => ":raw:encoding(UTF-8)" };
goto &slurp;
@@ -70216,9 +71924,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
#pod unbuffered, raw write.
#pod
- #pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>.
- #pod If L<Unicode::UTF8> 0.58+ is installed, a raw spew will be done instead on
- #pod the data encoded with C<Unicode::UTF8>.
+ #pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
+ #pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+ #pod spew will be done instead on the data encoded with C<Unicode::UTF8>.
#pod
#pod B<NOTE>: because the file is written to a temporary file and then renamed, the
#pod new file will wind up with permissions based on your current umask. This is a
@@ -70238,15 +71946,16 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
my $binmode = $args->{binmode};
# get default binmode from caller's lexical scope (see "perldoc open")
$binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
- my $temp = path( $self->[PATH] . $$ . int( rand( 2**31 ) ) );
+
+ # spewing need to follow the link
+ # and create the tempfile in the same dir
+ my $resolved_path = $self->_resolve_symlinks;
+
+ my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) );
my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data;
close $fh or $self->_throw( 'close', $temp->[PATH] );
- # spewing need to follow the link
- # and replace the destination instead
- my $resolved_path = $self->[PATH];
- $resolved_path = readlink $resolved_path while -l $resolved_path;
return $temp->move($resolved_path);
}
@@ -70255,7 +71964,15 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
sub spew_utf8 {
if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
my $self = shift;
- spew( $self, { binmode => ":unix" }, map { Unicode::UTF8::encode_utf8($_) } @_ );
+ spew(
+ $self,
+ { binmode => ":unix" },
+ map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
+ );
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
+ goto &spew;
}
else {
splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
@@ -70384,9 +72101,15 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
my $fh = $self->openw;
close $fh or $self->_throw('close');
}
- $epoch = defined($epoch) ? $epoch : time();
- utime $epoch, $epoch, $self->[PATH]
- or $self->_throw("utime ($epoch)");
+ if ( defined $epoch ) {
+ utime $epoch, $epoch, $self->[PATH]
+ or $self->_throw("utime ($epoch)");
+ }
+ else {
+ # literal undef prevents warnings :-(
+ utime undef, undef, $self->[PATH]
+ or $self->_throw("utime ()");
+ }
return $self;
}
@@ -70412,12 +72135,11 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod
#pod path("/tmp")->visit( \&callback, \%options );
#pod
- #pod Wraps the L</iterator> method to execute a callback for each directory entry.
- #pod It returns a hash reference with any state accumulated during
- #pod iteration.
+ #pod Executes a callback for each child of a directory. It returns a hash
+ #pod reference with any state accumulated during iteration.
#pod
- #pod The options are the same as for L</iterator>: C<recurse> and
- #pod C<follow_symlinks>. Both default to false.
+ #pod The options are the same as for L</iterator> (which it uses internally):
+ #pod C<recurse> and C<follow_symlinks>. Both default to false.
#pod
#pod The callback function will receive a C<Path::Tiny> object as the first argument
#pod and a hash reference to accumulate state as the second argument. For example:
@@ -70480,7 +72202,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod $vol = path("C:/tmp/foo.txt")->volume; # "C:"
#pod
#pod Returns the volume portion of the path. This is equivalent
- #pod equivalent to what L<File::Spec> would give from C<splitpath> and thus
+ #pod to what L<File::Spec> would give from C<splitpath> and thus
#pod usually is the empty string on Unix-like operating systems or the
#pod drive letter for an absolute path on C<MSWin32>.
#pod
@@ -70524,7 +72246,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 VERSION
- version 0.072
+ version 0.104
=head1 SYNOPSIS
@@ -70568,10 +72290,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 DESCRIPTION
- This module provide a small, fast utility for working with file paths. It is
+ This module provides a small, fast utility for working with file paths. It is
friendlier to use than L<File::Spec> and provides easy access to functions from
several other core file handling modules. It aims to be smaller and faster
- than many alternatives on CPAN while helping people do many common things in
+ than many alternatives on CPAN, while helping people do many common things in
consistent and less error-prone ways.
Path::Tiny does not try to work for anything except Unix-like and Win32
@@ -70585,10 +72307,15 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
File input/output methods C<flock> handles before reading or writing,
as appropriate (if supported by the platform).
- The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw mode.
- On Windows, that means they will not have CRLF translation from the C<:crlf> IO
- layer. Installing L<Unicode::UTF8> 0.58 or later will speed up C<*_utf8>
- situations in many cases and is highly recommended.
+ The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw
+ mode. On Windows, that means they will not have CRLF translation from the
+ C<:crlf> IO layer. Installing L<Unicode::UTF8> 0.58 or later will speed up
+ C<*_utf8> situations in many cases and is highly recommended.
+ Alternatively, installing L<PerlIO::utf8_strict> 0.003 or later will be
+ used in place of the default C<:encoding(UTF-8)>.
+
+ This module depends heavily on PerlIO layers for correct operation and thus
+ requires Perl 5.008001 or later.
=head1 CONSTRUCTORS
@@ -70690,7 +72417,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
The tempfile path object will be normalized to have an absolute path, even if
- created in a relative directory using C<DIR>.
+ created in a relative directory using C<DIR>. If you want it to have
+ the C<realpath> instead, pass a leading options hash like this:
+
+ $real_temp = tempfile({realpath => 1}, @options);
C<tempdir> is just like C<tempfile>, except it calls
C<< File::Temp->newdir >> instead.
@@ -70704,7 +72434,21 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
up.
- Current API available since 0.018.
+ B<Note 2>: if you don't want these cleaned up automatically when the object
+ is destroyed, File::Temp requires different options for directories and
+ files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
+ files.
+
+ B<Note 3>: Don't lose the temporary object by chaining a method call instead
+ of storing it:
+
+ my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
+
+ B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
+ Keeping a reference to, or modifying the cached object may break the
+ behavior documented above and is not supported. Use at your own risk.
+
+ Current API available since 0.097.
=head1 METHODS
@@ -70714,9 +72458,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$abs = path("foo/bar")->absolute("/tmp");
Returns a new C<Path::Tiny> object with an absolute path (or itself if already
- absolute). Unless an argument is given, the current directory is used as the
- absolute base path. The argument must be absolute or you won't get an absolute
- result.
+ absolute). If no argument is given, the current directory is used as the
+ absolute base path. If an argument is given, it will be converted to an
+ absolute path (if it is not already) and used as the absolute base path.
This will not resolve upward directories ("foo/../bar") unless C<canonpath>
in L<File::Spec> would normally do so on your platform. If you need them
@@ -70725,7 +72469,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
On Windows, an absolute path without a volume component will have it added
based on the current drive.
- Current API available since 0.001.
+ Current API available since 0.101.
=head2 append, append_raw, append_utf8
@@ -70758,8 +72502,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
unbuffered, raw write.
C<append_utf8> is like C<append> with a C<binmode> of
- C<:unix:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
- append will be done instead on the data encoded with C<Unicode::UTF8>.
+ C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+ 0.58+ is installed, a raw append will be done instead on the data encoded
+ with C<Unicode::UTF8>.
Current API available since 0.060.
@@ -70801,6 +72546,18 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
Current API available since 0.001.
+ =head2 cached_temp
+
+ Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
+ C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
+ If there is no such object, this method throws.
+
+ B<WARNING>: Keeping a reference to, or modifying the cached object may
+ break the behavior documented for temporary files and directories created
+ with C<Path::Tiny> and is not supported. Use at your own risk.
+
+ Current API available since 0.101.
+
=head2 child
$file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
@@ -70852,9 +72609,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
path("/tmp/foo.txt")->copy("/tmp/bar.txt");
- Copies a file using L<File::Copy>'s C<copy> function. Upon
- success, returns the C<Path::Tiny> object for the newly copied
- file.
+ Copies the current path to the given destination using L<File::Copy>'s
+ C<copy> function. Upon success, returns the C<Path::Tiny> object for the
+ newly copied file.
Current API available since 0.070.
@@ -70889,6 +72646,48 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
Deprecated in 0.056.
+ =head2 edit, edit_raw, edit_utf8
+
+ path("foo.txt")->edit( \&callback, $options );
+ path("foo.txt")->edit_utf8( \&callback );
+ path("foo.txt")->edit_raw( \&callback );
+
+ These are convenience methods that allow "editing" a file using a single
+ callback argument. They slurp the file using C<slurp>, place the contents
+ inside a localized C<$_> variable, call the callback function (without
+ arguments), and then write C<$_> (presumably mutated) back to the
+ file with C<spew>.
+
+ An optional hash reference may be used to pass options. The only option is
+ C<binmode>, which is passed to C<slurp> and C<spew>.
+
+ C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
+ C<spew_*> methods.
+
+ Current API available since 0.077.
+
+ =head2 edit_lines, edit_lines_utf8, edit_lines_raw
+
+ path("foo.txt")->edit_lines( \&callback, $options );
+ path("foo.txt")->edit_lines_utf8( \&callback );
+ path("foo.txt")->edit_lines_raw( \&callback );
+
+ These are convenience methods that allow "editing" a file's lines using a
+ single callback argument. They iterate over the file: for each line, the
+ line is put into a localized C<$_> variable, the callback function is
+ executed (without arguments) and then C<$_> is written to a temporary file.
+ When iteration is finished, the temporary file is atomically renamed over
+ the original.
+
+ An optional hash reference may be used to pass options. The only option is
+ C<binmode>, which is passed to the method that open handles for reading and
+ writing.
+
+ C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
+ C<slurp_*> and C<spew_*> methods.
+
+ Current API available since 0.077.
+
=head2 exists, is_file, is_dir
if ( path("/tmp")->exists ) { ... } # -e
@@ -70913,7 +72712,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode);
Returns an open file handle. The C<$mode> argument must be a Perl-style
- read/write mode string ("<" ,">", "<<", etc.). If a C<$binmode>
+ read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode>
is given, it is set during the C<open> call.
An optional hash reference may be used to pass options.
@@ -71022,8 +72821,8 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw>
instead of C<:unix> so PerlIO buffering can manage reading by line.
- C<lines_utf8> is like C<lines> with a C<binmode> of
- C<:raw:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
+ C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
+ (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
UTF-8 slurp will be done and then the lines will be split. This is
actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
intensive. If memory use is a concern, consider C<openr_utf8> and
@@ -71047,7 +72846,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
path("foo.txt")->move("bar.txt");
- Just like C<rename>.
+ Move the current path to the given destination path using Perl's
+ built-in L<rename|perlfunc/rename> function. Returns the result
+ of the C<rename> function.
Current API available since 0.001.
@@ -71128,11 +72929,58 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
- Returns a C<Path::Tiny> object with a relative path name.
- Given the trickiness of this, it's a thin wrapper around
- C<< File::Spec->abs2rel() >>.
+ Returns a C<Path::Tiny> object with a path relative to a new base path
+ given as an argument. If no argument is given, the current directory will
+ be used as the new base path.
- Current API available since 0.001.
+ If either path is already relative, it will be made absolute based on the
+ current directly before determining the new relative path.
+
+ The algorithm is roughly as follows:
+
+ =over 4
+
+ =item *
+
+ If the original and new base path are on different volumes, an exception will be thrown.
+
+ =item *
+
+ If the original and new base are identical, the relative path is C<".">.
+
+ =item *
+
+ If the new base subsumes the original, the relative path is the original path with the new base chopped off the front
+
+ =item *
+
+ If the new base does not subsume the original, a common prefix path is determined (possibly the root directory) and the relative path will consist of updirs (C<"..">) to reach the common prefix, followed by the original path less the common prefix.
+
+ =back
+
+ Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
+ on a common prefix takes into account symlinks that could affect the updir
+ process. Given an original path "/A/B" and a new base "/A/C",
+ (where "A", "B" and "C" could each have multiple path components):
+
+ =over 4
+
+ =item *
+
+ Symlinks in "A" don't change the result unless the last component of A is a symlink and the first component of "C" is an updir.
+
+ =item *
+
+ Symlinks in "B" don't change the result and will exist in the result as given.
+
+ =item *
+
+ Symlinks and updirs in "C" must be resolved to actual paths, taking into account the possibility that not all path components might exist on the filesystem.
+
+ =back
+
+ Current API available since 0.001. New algorithm (that accounts for
+ symlinks) available since 0.079.
=head2 remove
@@ -71181,18 +73029,18 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$data = path("foo.txt")->slurp_raw;
$data = path("foo.txt")->slurp_utf8;
- Reads file contents into a scalar. Takes an optional hash reference may be
- used to pass options. The only option is C<binmode>, which is passed to
- C<binmode()> on the handle used for reading.
+ Reads file contents into a scalar. Takes an optional hash reference which may
+ be used to pass options. The only available option is C<binmode>, which is
+ passed to C<binmode()> on the handle used for reading.
C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
a fast, unbuffered, raw read.
C<slurp_utf8> is like C<slurp> with a C<binmode> of
- C<:unix:encoding(UTF-8)>. If L<Unicode::UTF8> 0.58+ is installed, a raw
- slurp will be done instead and the result decoded with C<Unicode::UTF8>.
- This is just as strict and is roughly an order of magnitude faster than
- using C<:encoding(UTF-8)>.
+ C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+ 0.58+ is installed, a raw slurp will be done instead and the result decoded
+ with C<Unicode::UTF8>. This is just as strict and is roughly an order of
+ magnitude faster than using C<:encoding(UTF-8)>.
B<Note>: C<slurp> and friends lock the filehandle before slurping. If
you plan to slurp from a file created with L<File::Temp>, be sure to
@@ -71219,9 +73067,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
unbuffered, raw write.
- C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>.
- If L<Unicode::UTF8> 0.58+ is installed, a raw spew will be done instead on
- the data encoded with C<Unicode::UTF8>.
+ C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
+ (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+ spew will be done instead on the data encoded with C<Unicode::UTF8>.
B<NOTE>: because the file is written to a temporary file and then renamed, the
new file will wind up with permissions based on your current umask. This is a
@@ -71300,12 +73148,11 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
path("/tmp")->visit( \&callback, \%options );
- Wraps the L</iterator> method to execute a callback for each directory entry.
- It returns a hash reference with any state accumulated during
- iteration.
+ Executes a callback for each child of a directory. It returns a hash
+ reference with any state accumulated during iteration.
- The options are the same as for L</iterator>: C<recurse> and
- C<follow_symlinks>. Both default to false.
+ The options are the same as for L</iterator> (which it uses internally):
+ C<recurse> and C<follow_symlinks>. Both default to false.
The callback function will receive a C<Path::Tiny> object as the first argument
and a hash reference to accumulate state as the second argument. For example:
@@ -71350,7 +73197,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$vol = path("C:/tmp/foo.txt")->volume; # "C:"
Returns the volume portion of the path. This is equivalent
- equivalent to what L<File::Spec> would give from C<splitpath> and thus
+ to what L<File::Spec> would give from C<splitpath> and thus
usually is the empty string on Unix-like operating systems or the
drive letter for an absolute path on C<MSWin32>.
@@ -71358,7 +73205,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8
openr_raw opena_raw openw_raw openrw_raw
- IS_BSD IS_WIN32 FREEZE THAW TO_JSON
+ IS_BSD IS_WIN32 FREEZE THAW TO_JSON abs2rel
=head1 EXCEPTION HANDLING
@@ -71392,6 +73239,12 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 CAVEATS
+ =head2 Subclassing not supported
+
+ For speed, this class is implemented as an array based object and uses many
+ direct function calls internally. You must not subclass it and expect
+ things to work properly.
+
=head2 File locking
If flock is not supported on a platform, it will not be used, even if
@@ -71418,7 +73271,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head2 utf8 vs UTF-8
- All the C<*_utf8> methods use C<:encoding(UTF-8)> -- either as
+ All the C<*_utf8> methods by default use C<:encoding(UTF-8)> -- either as
C<:unix:encoding(UTF-8)> (unbuffered) or C<:raw:encoding(UTF-8)> (buffered) --
which is strict against the Unicode spec and disallows illegal Unicode
codepoints or UTF-8 sequences.
@@ -71426,7 +73279,8 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
Unfortunately, C<:encoding(UTF-8)> is very, very slow. If you install
L<Unicode::UTF8> 0.58 or later, that module will be used by some C<*_utf8>
methods to encode or decode data after a raw, binary input/output operation,
- which is much faster.
+ which is much faster. Alternatively, if you install L<PerlIO::utf8_strict>,
+ that will be used instead of C<:encoding(UTF-8)> and is also very fast.
If you need the performance and can accept the security risk,
C<< slurp({binmode => ":unix:utf8"}) >> will be faster than C<:unix:encoding(UTF-8)>
@@ -71439,10 +73293,6 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$path->spew_utf8($data); # raw
$path->spew({binmode => ":encoding(UTF-8)"}, $data; # LF -> CRLF
- Consider L<PerlIO::utf8_strict> for a faster L<PerlIO> layer alternative to
- C<:encoding(UTF-8)>, though it does not appear to be as fast as the
- C<Unicode::UTF8> approach.
-
=head2 Default IO layers and the open pragma
If you have Perl 5.10 or later, file input/output methods (C<slurp>, C<spew>,
@@ -71527,7 +73377,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 CONTRIBUTORS
- =for stopwords Alex Efros Chris Williams David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop James Hunt Karen Etheridge Martin Kjeldsen Michael G. Schwern Philippe Bruhat (BooK) Regina Verbae regina-verbae Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim
+ =for stopwords Alex Efros Chris Williams Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis James Hunt John Karr Karen Etheridge Mark Ellis Martin Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) Regina Verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim
=over 4
@@ -71541,6 +73391,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Dave Rolsky <autarch@urth.org>
+
+ =item *
+
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
@@ -71573,14 +73427,26 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Graham Ollis <plicease@cpan.org>
+
+ =item *
+
James Hunt <james@niftylogic.com>
=item *
+ John Karr <brainbuz@brainbuz.org>
+
+ =item *
+
Karen Etheridge <ether@cpan.org>
=item *
+ Mark Ellis <mark.ellis@cartridgesave.co.uk>
+
+ =item *
+
Martin Kjeldsen <mk@bluepipe.dk>
=item *
@@ -71589,6 +73455,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Nigel Gregoire <nigelgregoire@gmail.com>
+
+ =item *
+
Philippe Bruhat (BooK) <book@cpan.org>
=item *
@@ -71597,7 +73467,11 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
- regina-verbae <regina-verbae@users.noreply.github.com>
+ Roy Ivy III <rivy@cpan.org>
+
+ =item *
+
+ Shlomi Fish <shlomif@shlomifish.org>
=item *
@@ -71632,175 +73506,12 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=cut
PATH_TINY
-$fatpacked{"Sub/Exporter/Progressive.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_EXPORTER_PROGRESSIVE';
- package Sub::Exporter::Progressive;
-
- use strict;
- use warnings;
-
- our $VERSION = '0.001011';
-
- use Carp ();
- use List::Util ();
-
- sub import {
- my ($self, @args) = @_;
-
- my $inner_target = caller;
- my $export_data = sub_export_options($inner_target, @args);
-
- my $full_exporter;
- no strict 'refs';
- @{"${inner_target}::EXPORT_OK"} = @{$export_data->{exports}};
- @{"${inner_target}::EXPORT"} = @{$export_data->{defaults}};
- %{"${inner_target}::EXPORT_TAGS"} = %{$export_data->{tags}};
- *{"${inner_target}::import"} = sub {
- use strict;
- my ($self, @args) = @_;
-
- if (List::Util::first { ref || !m/ \A [:-]? \w+ \z /xm } @args) {
- Carp::croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed'
- unless eval { require Sub::Exporter };
- $full_exporter ||= Sub::Exporter::build_exporter($export_data->{original});
-
- goto $full_exporter;
- } elsif (defined(my $num = List::Util::first { !ref and m/^\d/ } @args)) {
- die "cannot export symbols with a leading digit: '$num'";
- } else {
- require Exporter;
- s/ \A - /:/xm for @args;
- @_ = ($self, @args);
- goto \&Exporter::import;
- }
- };
- return;
- }
-
- my $too_complicated = <<'DEATH';
- You are using Sub::Exporter::Progressive, but the features your program uses from
- Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well
- just use vanilla Sub::Exporter
- DEATH
-
- sub sub_export_options {
- my ($inner_target, $setup, $options) = @_;
-
- my @exports;
- my @defaults;
- my %tags;
-
- if ($setup eq '-setup') {
- my %options = %$options;
-
- OPTIONS:
- for my $opt (keys %options) {
- if ($opt eq 'exports') {
-
- Carp::croak $too_complicated if ref $options{exports} ne 'ARRAY';
- @exports = @{$options{exports}};
- Carp::croak $too_complicated if List::Util::first { ref } @exports;
-
- } elsif ($opt eq 'groups') {
- %tags = %{$options{groups}};
- for my $tagset (values %tags) {
- Carp::croak $too_complicated if List::Util::first { / \A - (?! all \b ) /x || ref } @{$tagset};
- }
- @defaults = @{$tags{default} || [] };
- } else {
- Carp::croak $too_complicated;
- }
- }
- @{$_} = map { / \A [:-] all \z /x ? @exports : $_ } @{$_} for \@defaults, values %tags;
- $tags{all} ||= [ @exports ];
- my %exports = map { $_ => 1 } @exports;
- my @errors = grep { not $exports{$_} } @defaults;
- Carp::croak join(', ', @errors) . " is not exported by the $inner_target module\n" if @errors;
- }
-
- return {
- exports => \@exports,
- defaults => \@defaults,
- original => $options,
- tags => \%tags,
- };
- }
-
- 1;
-
- =encoding utf8
-
- =head1 NAME
-
- Sub::Exporter::Progressive - Only use Sub::Exporter if you need it
-
- =head1 SYNOPSIS
-
- package Syntax::Keyword::Gather;
-
- use Sub::Exporter::Progressive -setup => {
- exports => [qw( break gather gathered take )],
- groups => {
- default => [qw( break gather gathered take )],
- },
- };
-
- # elsewhere
-
- # uses Exporter for speed
- use Syntax::Keyword::Gather;
-
- # somewhere else
-
- # uses Sub::Exporter for features
- use Syntax::Keyword::Gather 'gather', take => { -as => 'grab' };
-
- =head1 DESCRIPTION
-
- L<Sub::Exporter> is an incredibly powerful module, but with that power comes
- great responsibility, er- as well as some runtime penalties. This module
- is a C<Sub::Exporter> wrapper that will let your users just use L<Exporter>
- if all they are doing is picking exports, but use C<Sub::Exporter> if your
- users try to use C<Sub::Exporter>'s more advanced features, like
- renaming exports, if they try to use them.
-
- Note that this module will export C<@EXPORT>, C<@EXPORT_OK> and
- C<%EXPORT_TAGS> package variables for C<Exporter> to work. Additionally, if
- your package uses advanced C<Sub::Exporter> features like currying, this module
- will only ever use C<Sub::Exporter>, so you might as well use it directly.
-
- =head1 AUTHOR
-
- frew - Arthur Axel Schmidt (cpan:FREW) <frioux+cpan@gmail.com>
-
- =head1 CONTRIBUTORS
-
- ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
-
- mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
-
- leont - Leon Timmermans (cpan:LEONT) <leont@cpan.org>
-
- =head1 COPYRIGHT
-
- Copyright (c) 2012 the Sub::Exporter::Progressive L</AUTHOR> and
- L</CONTRIBUTORS> as listed above.
-
- =head1 LICENSE
-
- This library is free software and may be distributed under the same terms
- as perl itself.
-
- =cut
-SUB_EXPORTER_PROGRESSIVE
-
$fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
- package Try::Tiny;
- BEGIN {
- $Try::Tiny::AUTHORITY = 'cpan:NUFFIN';
- }
- $Try::Tiny::VERSION = '0.22';
+ package Try::Tiny; # git description: v0.27-8-g8dc27c7
use 5.006;
- # ABSTRACT: minimal try/catch with proper preservation of $@
+ # ABSTRACT: Minimal try/catch with proper preservation of $@
+
+ our $VERSION = '0.28';
use strict;
use warnings;
@@ -71811,7 +73522,23 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
use Carp;
$Carp::Internal{+__PACKAGE__}++;
- BEGIN { eval "use Sub::Name; 1" or *{subname} = sub {1} }
+ BEGIN {
+ my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname;
+ my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) };
+ unless ($su || $sn) {
+ $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname;
+ unless ($su) {
+ $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) };
+ }
+ }
+
+ *_subname = $su ? \&Sub::Util::set_subname
+ : $sn ? \&Sub::Name::subname
+ : sub { $_[1] };
+ *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
+ }
+
+ my %_finally_guards;
# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
@@ -71853,9 +73580,17 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
# name the blocks if we have Sub::Name installed
my $caller = caller;
- subname("${caller}::try {...} " => $try);
- subname("${caller}::catch {...} " => $catch) if $catch;
- subname("${caller}::finally {...} " => $_) foreach @finally;
+ _subname("${caller}::try {...} " => $try)
+ if _HAS_SUBNAME;
+
+ # set up scope guards to invoke the finally blocks at the end.
+ # this should really be a function scope lexical variable instead of
+ # file scope + local but that causes issues with perls < 5.20 due to
+ # perl rt#119311
+ local $_finally_guards{guards} = [
+ map { Try::Tiny::ScopeGuard->_new($_) }
+ @finally
+ ];
# save the value of $@ so we can set $@ back to it in the beginning of the eval
# and restore $@ after the eval finishes
@@ -71877,21 +73612,19 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
$try->();
};
- return 1; # properly set $fail to false
+ return 1; # properly set $failed to false
};
# preserve the current error and reset the original value of $@
$error = $@;
$@ = $prev_error;
- # set up a scope guard to invoke the finally block at the end
- my @guards =
- map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
- @finally;
-
# at this point $failed contains a true value if the eval died, even if some
# destructor overwrote $@ as the eval was unwinding.
if ( $failed ) {
+ # pass $error to the finally blocks
+ push @$_, $error for @{$_finally_guards{guards}};
+
# if we got an error, invoke the catch block.
if ( $catch ) {
# This works like given($error), but is backwards compatible and
@@ -71916,6 +73649,9 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
croak 'Useless bare catch()' unless wantarray;
+ my $caller = caller;
+ _subname("${caller}::catch {...} " => $block)
+ if _HAS_SUBNAME;
return (
bless(\$block, 'Try::Tiny::Catch'),
@rest,
@@ -71927,6 +73663,9 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
croak 'Useless bare finally()' unless wantarray;
+ my $caller = caller;
+ _subname("${caller}::finally {...} " => $block)
+ if _HAS_SUBNAME;
return (
bless(\$block, 'Try::Tiny::Finally'),
@rest,
@@ -71937,7 +73676,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
package # hide from PAUSE
Try::Tiny::ScopeGuard;
- use constant UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0;
+ use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
sub _new {
shift;
@@ -71974,11 +73713,11 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=head1 NAME
- Try::Tiny - minimal try/catch with proper preservation of $@
+ Try::Tiny - Minimal try/catch with proper preservation of $@
=head1 VERSION
- version 0.22
+ version 0.28
=head1 SYNOPSIS
@@ -72027,8 +73766,8 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
assign C<"bar"> to C<$x>:
my $x = try { die "foo" } catch { "bar" };
- my $x = try { die "foo" } || { "bar" };
- my $x = (try { die "foo" }) // { "bar" };
+ my $x = try { die "foo" } || "bar";
+ my $x = (try { die "foo" }) // "bar";
my $x = eval { die "foo" } || "bar";
@@ -72253,6 +73992,8 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
Using Perl 5.10 you can use L<perlsyn/"Switch statements">.
+ =for stopwords topicalizer
+
The C<catch> block is invoked in a topicalizer context (like a C<given> block),
but note that you can't return a useful value from C<catch> using the C<when>
blocks without an explicit C<return>.
@@ -72274,7 +74015,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=item *
C<@_> is not available within the C<try> block, so you need to copy your
- arglist. In case you want to work with argument values directly via C<@_>
+ argument list. In case you want to work with argument values directly via C<@_>
aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:
sub foo {
@@ -72342,11 +74083,13 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
will not report this when using full stack traces, though, because
C<%Carp::Internal> is used. This lack of magic is considered a feature.
+ =for stopwords unhygienically
+
=item *
The value of C<$_> in the C<catch> block is not guaranteed to be the value of
the exception thrown (C<$@>) in the C<try> block. There is no safe way to
- ensure this, since C<eval> may be used unhygenically in destructors. The only
+ ensure this, since C<eval> may be used unhygienically in destructors. The only
guarantee is that the C<catch> will be called if an exception is thrown.
=item *
@@ -72394,7 +74137,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
Note that this behavior was changed once again in L<Perl5 version 18
|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
- However, since the entirety of lexical C<$_> is now L<considired experimental
+ However, since the entirety of lexical C<$_> is now L<considered experimental
|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
is unclear whether the new version 18 behavior is final.
@@ -72444,9 +74187,10 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
- =head1 VERSION CONTROL
+ =head1 SUPPORT
- L<http://github.com/doy/try-tiny/>
+ Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny>
+ (or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>).
=head1 AUTHORS
@@ -72454,7 +74198,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=item *
- Yuval Kogman <nothingmuch@woobling.org>
+ יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
@@ -72462,9 +74206,105 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=back
- =head1 COPYRIGHT AND LICENSE
+ =head1 CONTRIBUTORS
+
+ =for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Dagfinn Ilmari Mannsåker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jonathan Yu Marc Mims Stosberg Pali
+
+ =over 4
+
+ =item *
+
+ Karen Etheridge <ether@cpan.org>
+
+ =item *
+
+ Peter Rabbitson <ribasushi@cpan.org>
- This software is Copyright (c) 2014 by Yuval Kogman.
+ =item *
+
+ Ricardo Signes <rjbs@cpan.org>
+
+ =item *
+
+ Mark Fowler <mark@twoshortplanks.com>
+
+ =item *
+
+ Graham Knop <haarg@haarg.org>
+
+ =item *
+
+ Lukas Mai <l.mai@web.de>
+
+ =item *
+
+ Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+ =item *
+
+ Paul Howarth <paul@city-fan.org>
+
+ =item *
+
+ Rudolf Leermakers <rudolf@hatsuseno.org>
+
+ =item *
+
+ anaxagoras <walkeraj@gmail.com>
+
+ =item *
+
+ awalker <awalker@sourcefire.com>
+
+ =item *
+
+ chromatic <chromatic@wgz.org>
+
+ =item *
+
+ Alex <alex@koban.(none)>
+
+ =item *
+
+ cm-perl <cm-perl@users.noreply.github.com>
+
+ =item *
+
+ Andrew Yates <ayates@haddock.local>
+
+ =item *
+
+ David Lowe <davidl@lokku.com>
+
+ =item *
+
+ Glenn Fowler <cebjyre@cpan.org>
+
+ =item *
+
+ Hans Dieter Pearcey <hdp@weftsoar.net>
+
+ =item *
+
+ Jonathan Yu <JAWNSY@cpan.org>
+
+ =item *
+
+ Marc Mims <marc@questright.com>
+
+ =item *
+
+ Mark Stosberg <mark@stosberg.com>
+
+ =item *
+
+ Pali <pali@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENCE
+
+ This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman).
This is free software, licensed under:
@@ -72760,4558 +74600,6 @@ $fatpacked{"Types/Serialiser/Error.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
TYPES_SERIALISER_ERROR
-$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT';
- package parent;
- use strict;
- use vars qw($VERSION);
- $VERSION = '0.234';
-
- sub import {
- my $class = shift;
-
- my $inheritor = caller(0);
-
- if ( @_ and $_[0] eq '-norequire' ) {
- shift @_;
- } else {
- for ( my @filename = @_ ) {
- s{::|'}{/}g;
- require "$_.pm"; # dies if the file is not found
- }
- }
-
- {
- no strict 'refs';
- push @{"$inheritor\::ISA"}, @_;
- };
- };
-
- "All your base are belong to us"
-
- __END__
-
- =encoding utf8
-
- =head1 NAME
-
- parent - Establish an ISA relationship with base classes at compile time
-
- =head1 SYNOPSIS
-
- package Baz;
- use parent qw(Foo Bar);
-
- =head1 DESCRIPTION
-
- Allows you to both load one or more modules, while setting up inheritance from
- those modules at the same time. Mostly similar in effect to
-
- package Baz;
- BEGIN {
- require Foo;
- require Bar;
- push @ISA, qw(Foo Bar);
- }
-
- By default, every base class needs to live in a file of its own.
- If you want to have a subclass and its parent class in the same file, you
- can tell C<parent> not to load any modules by using the C<-norequire> switch:
-
- package Foo;
- sub exclaim { "I CAN HAS PERL" }
-
- package DoesNotLoadFooBar;
- use parent -norequire, 'Foo', 'Bar';
- # will not go looking for Foo.pm or Bar.pm
-
- This is equivalent to the following code:
-
- package Foo;
- sub exclaim { "I CAN HAS PERL" }
-
- package DoesNotLoadFooBar;
- push @DoesNotLoadFooBar::ISA, 'Foo', 'Bar';
-
- This is also helpful for the case where a package lives within
- a differently named file:
-
- package MyHash;
- use Tie::Hash;
- use parent -norequire, 'Tie::StdHash';
-
- This is equivalent to the following code:
-
- package MyHash;
- require Tie::Hash;
- push @ISA, 'Tie::StdHash';
-
- If you want to load a subclass from a file that C<require> would
- not consider an eligible filename (that is, it does not end in
- either C<.pm> or C<.pmc>), use the following code:
-
- package MySecondPlugin;
- require './plugins/custom.plugin'; # contains Plugin::Custom
- use parent -norequire, 'Plugin::Custom';
-
- =head1 HISTORY
-
- This module was forked from L<base> to remove the cruft
- that had accumulated in it.
-
- =head1 CAVEATS
-
- =head1 SEE ALSO
-
- L<base>
-
- =head1 AUTHORS AND CONTRIBUTORS
-
- Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern
-
- =head1 MAINTAINER
-
- Max Maischein C< corion@cpan.org >
-
- Copyright (c) 2007-10 Max Maischein C<< <corion@cpan.org> >>
- Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
-
- =head1 LICENSE
-
- This module is released under the same terms as Perl itself.
-
- =cut
-PARENT
-
-$fatpacked{"Cwd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_CWD';
- package Cwd;
-
- =head1 NAME
-
- Cwd - get pathname of current working directory
-
- =head1 SYNOPSIS
-
- use Cwd;
- my $dir = getcwd;
-
- use Cwd 'abs_path';
- my $abs_path = abs_path($file);
-
- =head1 DESCRIPTION
-
- This module provides functions for determining the pathname of the
- current working directory. It is recommended that getcwd (or another
- *cwd() function) be used in I<all> code to ensure portability.
-
- By default, it exports the functions cwd(), getcwd(), fastcwd(), and
- fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
-
-
- =head2 getcwd and friends
-
- Each of these functions are called without arguments and return the
- absolute path of the current working directory.
-
- =over 4
-
- =item getcwd
-
- my $cwd = getcwd();
-
- Returns the current working directory.
-
- Exposes the POSIX function getcwd(3) or re-implements it if it's not
- available.
-
- =item cwd
-
- my $cwd = cwd();
-
- The cwd() is the most natural form for the current architecture. For
- most systems it is identical to `pwd` (but without the trailing line
- terminator).
-
- =item fastcwd
-
- my $cwd = fastcwd();
-
- A more dangerous version of getcwd(), but potentially faster.
-
- It might conceivably chdir() you out of a directory that it can't
- chdir() you back into. If fastcwd encounters a problem it will return
- undef but will probably leave you in a different directory. For a
- measure of extra security, if everything appears to have worked, the
- fastcwd() function will check that it leaves you in the same directory
- that it started in. If it has changed it will C<die> with the message
- "Unstable directory path, current directory changed
- unexpectedly". That should never happen.
-
- =item fastgetcwd
-
- my $cwd = fastgetcwd();
-
- The fastgetcwd() function is provided as a synonym for cwd().
-
- =item getdcwd
-
- my $cwd = getdcwd();
- my $cwd = getdcwd('C:');
-
- The getdcwd() function is also provided on Win32 to get the current working
- directory on the specified drive, since Windows maintains a separate current
- working directory for each drive. If no drive is specified then the current
- drive is assumed.
-
- This function simply calls the Microsoft C library _getdcwd() function.
-
- =back
-
-
- =head2 abs_path and friends
-
- These functions are exported only on request. They each take a single
- argument and return the absolute pathname for it. If no argument is
- given they'll use the current working directory.
-
- =over 4
-
- =item abs_path
-
- my $abs_path = abs_path($file);
-
- Uses the same algorithm as getcwd(). Symbolic links and relative-path
- components ("." and "..") are resolved to return the canonical
- pathname, just like realpath(3).
-
- =item realpath
-
- my $abs_path = realpath($file);
-
- A synonym for abs_path().
-
- =item fast_abs_path
-
- my $abs_path = fast_abs_path($file);
-
- A more dangerous, but potentially faster version of abs_path.
-
- =back
-
- =head2 $ENV{PWD}
-
- If you ask to override your chdir() built-in function,
-
- use Cwd qw(chdir);
-
- then your PWD environment variable will be kept up to date. Note that
- it will only be kept up to date if all packages which use chdir import
- it from Cwd.
-
-
- =head1 NOTES
-
- =over 4
-
- =item *
-
- Since the path separators are different on some operating systems ('/'
- on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
- modules wherever portability is a concern.
-
- =item *
-
- Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
- functions are all aliases for the C<cwd()> function, which, on Mac OS,
- calls `pwd`. Likewise, the C<abs_path()> function is an alias for
- C<fast_abs_path()>.
-
- =back
-
- =head1 AUTHOR
-
- Originally by the perl5-porters.
-
- Maintained by Ken Williams <KWILLIAMS@cpan.org>
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- Portions of the C code in this library are copyright (c) 1994 by the
- Regents of the University of California. All rights reserved. The
- license on this code is compatible with the licensing of the rest of
- the distribution - please see the source code in F<Cwd.xs> for the
- details.
-
- =head1 SEE ALSO
-
- L<File::chdir>
-
- =cut
-
- use strict;
- use Exporter;
- use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-
- $VERSION = '3.47';
- my $xs_version = $VERSION;
- $VERSION =~ tr/_//;
-
- @ISA = qw/ Exporter /;
- @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
- push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
- @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
-
- # sys_cwd may keep the builtin command
-
- # All the functionality of this module may provided by builtins,
- # there is no sense to process the rest of the file.
- # The best choice may be to have this in BEGIN, but how to return from BEGIN?
-
- if ($^O eq 'os2') {
- local $^W = 0;
-
- *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *getcwd = \&cwd;
- *fastgetcwd = \&cwd;
- *fastcwd = \&cwd;
-
- *fast_abs_path = \&sys_abspath if defined &sys_abspath;
- *abs_path = \&fast_abs_path;
- *realpath = \&fast_abs_path;
- *fast_realpath = \&fast_abs_path;
-
- return 1;
- }
-
- # Need to look up the feature settings on VMS. The preferred way is to use the
- # VMS::Feature module, but that may not be available to dual life modules.
-
- my $use_vms_feature;
- BEGIN {
- if ($^O eq 'VMS') {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $use_vms_feature = 1;
- }
- }
- }
-
- # Need to look up the UNIX report mode. This may become a dynamic mode
- # in the future.
- sub _vms_unix_rpt {
- my $unix_rpt;
- if ($use_vms_feature) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- }
- return $unix_rpt;
- }
-
- # Need to look up the EFS character set mode. This may become a dynamic
- # mode in the future.
- sub _vms_efs {
- my $efs;
- if ($use_vms_feature) {
- $efs = VMS::Feature::current("efs_charset");
- } else {
- my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
- $efs = $env_efs =~ /^[ET1]/i;
- }
- return $efs;
- }
-
-
- # If loading the XS stuff doesn't work, we can fall back to pure perl
- unless (defined &getcwd) {
- eval {
- if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load( __PACKAGE__, $xs_version);
- } else {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- __PACKAGE__->bootstrap( $xs_version );
- }
- };
- }
-
- # Big nasty table of function aliases
- my %METHOD_MAP =
- (
- VMS =>
- {
- cwd => '_vms_cwd',
- getcwd => '_vms_cwd',
- fastcwd => '_vms_cwd',
- fastgetcwd => '_vms_cwd',
- abs_path => '_vms_abs_path',
- fast_abs_path => '_vms_abs_path',
- },
-
- MSWin32 =>
- {
- # We assume that &_NT_cwd is defined as an XSUB or in the core.
- cwd => '_NT_cwd',
- getcwd => '_NT_cwd',
- fastcwd => '_NT_cwd',
- fastgetcwd => '_NT_cwd',
- abs_path => 'fast_abs_path',
- realpath => 'fast_abs_path',
- },
-
- dos =>
- {
- cwd => '_dos_cwd',
- getcwd => '_dos_cwd',
- fastgetcwd => '_dos_cwd',
- fastcwd => '_dos_cwd',
- abs_path => 'fast_abs_path',
- },
-
- # QNX4. QNX6 has a $os of 'nto'.
- qnx =>
- {
- cwd => '_qnx_cwd',
- getcwd => '_qnx_cwd',
- fastgetcwd => '_qnx_cwd',
- fastcwd => '_qnx_cwd',
- abs_path => '_qnx_abs_path',
- fast_abs_path => '_qnx_abs_path',
- },
-
- cygwin =>
- {
- getcwd => 'cwd',
- fastgetcwd => 'cwd',
- fastcwd => 'cwd',
- abs_path => 'fast_abs_path',
- realpath => 'fast_abs_path',
- },
-
- epoc =>
- {
- cwd => '_epoc_cwd',
- getcwd => '_epoc_cwd',
- fastgetcwd => '_epoc_cwd',
- fastcwd => '_epoc_cwd',
- abs_path => 'fast_abs_path',
- },
-
- MacOS =>
- {
- getcwd => 'cwd',
- fastgetcwd => 'cwd',
- fastcwd => 'cwd',
- abs_path => 'fast_abs_path',
- },
- );
-
- $METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
-
-
- # Find the pwd command in the expected locations. We assume these
- # are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
- # so everything works under taint mode.
- my $pwd_cmd;
- foreach my $try ('/bin/pwd',
- '/usr/bin/pwd',
- '/QOpenSys/bin/pwd', # OS/400 PASE.
- ) {
-
- if( -x $try ) {
- $pwd_cmd = $try;
- last;
- }
- }
-
- # Android has a built-in pwd. Using $pwd_cmd will DTRT if
- # this perl was compiled with -Dd_useshellcmds, which is the
- # default for Android, but the block below is needed for the
- # miniperl running on the host when cross-compiling, and
- # potentially for native builds with -Ud_useshellcmds.
- if ($^O =~ /android/) {
- # If targetsh is executable, then we're either a full
- # perl, or a miniperl for a native build.
- if (-x $Config::Config{targetsh}) {
- $pwd_cmd = "$Config::Config{targetsh} -c pwd"
- }
- else {
- $pwd_cmd = "$Config::Config{sh} -c pwd"
- }
- }
-
- my $found_pwd_cmd = defined($pwd_cmd);
- unless ($pwd_cmd) {
- # Isn't this wrong? _backtick_pwd() will fail if someone has
- # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
- # See [perl #16774]. --jhi
- $pwd_cmd = 'pwd';
- }
-
- # Lazy-load Carp
- sub _carp { require Carp; Carp::carp(@_) }
- sub _croak { require Carp; Carp::croak(@_) }
-
- # The 'natural and safe form' for UNIX (pwd may be setuid root)
- sub _backtick_pwd {
- # Localize %ENV entries in a way that won't create new hash keys
- my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
- local @ENV{@localize};
-
- my $cwd = `$pwd_cmd`;
- # Belt-and-suspenders in case someone said "undef $/".
- local $/ = "\n";
- # `pwd` may fail e.g. if the disk is full
- chomp($cwd) if defined $cwd;
- $cwd;
- }
-
- # Since some ports may predefine cwd internally (e.g., NT)
- # we take care not to override an existing definition for cwd().
-
- unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
- # The pwd command is not available in some chroot(2)'ed environments
- my $sep = $Config::Config{path_sep} || ':';
- my $os = $^O; # Protect $^O from tainting
-
-
- # Try again to find a pwd, this time searching the whole PATH.
- if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
- my @candidates = split($sep, $ENV{PATH});
- while (!$found_pwd_cmd and @candidates) {
- my $candidate = shift @candidates;
- $found_pwd_cmd = 1 if -x "$candidate/pwd";
- }
- }
-
- # MacOS has some special magic to make `pwd` work.
- if( $os eq 'MacOS' || $found_pwd_cmd )
- {
- *cwd = \&_backtick_pwd;
- }
- else {
- *cwd = \&getcwd;
- }
- }
-
- if ($^O eq 'cygwin') {
- # We need to make sure cwd() is called with no args, because it's
- # got an arg-less prototype and will die if args are present.
- local $^W = 0;
- my $orig_cwd = \&cwd;
- *cwd = sub { &$orig_cwd() }
- }
-
-
- # set a reasonable (and very safe) default for fastgetcwd, in case it
- # isn't redefined later (20001212 rspier)
- *fastgetcwd = \&cwd;
-
- # A non-XS version of getcwd() - also used to bootstrap the perl build
- # process, when miniperl is running and no XS loading happens.
- sub _perl_getcwd
- {
- abs_path('.');
- }
-
- # By John Bazik
- #
- # Usage: $cwd = &fastcwd;
- #
- # This is a faster version of getcwd. It's also more dangerous because
- # you might chdir out of a directory that you can't chdir back into.
-
- sub fastcwd_ {
- my($odev, $oino, $cdev, $cino, $tdev, $tino);
- my(@path, $path);
- local(*DIR);
-
- my($orig_cdev, $orig_cino) = stat('.');
- ($cdev, $cino) = ($orig_cdev, $orig_cino);
- for (;;) {
- my $direntry;
- ($odev, $oino) = ($cdev, $cino);
- CORE::chdir('..') || return undef;
- ($cdev, $cino) = stat('.');
- last if $odev == $cdev && $oino == $cino;
- opendir(DIR, '.') || return undef;
- for (;;) {
- $direntry = readdir(DIR);
- last unless defined $direntry;
- next if $direntry eq '.';
- next if $direntry eq '..';
-
- ($tdev, $tino) = lstat($direntry);
- last unless $tdev != $odev || $tino != $oino;
- }
- closedir(DIR);
- return undef unless defined $direntry; # should never happen
- unshift(@path, $direntry);
- }
- $path = '/' . join('/', @path);
- if ($^O eq 'apollo') { $path = "/".$path; }
- # At this point $path may be tainted (if tainting) and chdir would fail.
- # Untaint it then check that we landed where we started.
- $path =~ /^(.*)\z/s # untaint
- && CORE::chdir($1) or return undef;
- ($cdev, $cino) = stat('.');
- die "Unstable directory path, current directory changed unexpectedly"
- if $cdev != $orig_cdev || $cino != $orig_cino;
- $path;
- }
- if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
-
-
- # Keeps track of current working directory in PWD environment var
- # Usage:
- # use Cwd 'chdir';
- # chdir $newdir;
-
- my $chdir_init = 0;
-
- sub chdir_init {
- if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
- my($dd,$di) = stat('.');
- my($pd,$pi) = stat($ENV{'PWD'});
- if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
- $ENV{'PWD'} = cwd();
- }
- }
- else {
- my $wd = cwd();
- $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
- $ENV{'PWD'} = $wd;
- }
- # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
- if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
- my($pd,$pi) = stat($2);
- my($dd,$di) = stat($1);
- if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
- $ENV{'PWD'}="$2$3";
- }
- }
- $chdir_init = 1;
- }
-
- sub chdir {
- my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
- $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
- chdir_init() unless $chdir_init;
- my $newpwd;
- if ($^O eq 'MSWin32') {
- # get the full path name *before* the chdir()
- $newpwd = Win32::GetFullPathName($newdir);
- }
-
- return 0 unless CORE::chdir $newdir;
-
- if ($^O eq 'VMS') {
- return $ENV{'PWD'} = $ENV{'DEFAULT'}
- }
- elsif ($^O eq 'MacOS') {
- return $ENV{'PWD'} = cwd();
- }
- elsif ($^O eq 'MSWin32') {
- $ENV{'PWD'} = $newpwd;
- return 1;
- }
-
- if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
- $ENV{'PWD'} = cwd();
- } elsif ($newdir =~ m#^/#s) {
- $ENV{'PWD'} = $newdir;
- } else {
- my @curdir = split(m#/#,$ENV{'PWD'});
- @curdir = ('') unless @curdir;
- my $component;
- foreach $component (split(m#/#, $newdir)) {
- next if $component eq '.';
- pop(@curdir),next if $component eq '..';
- push(@curdir,$component);
- }
- $ENV{'PWD'} = join('/',@curdir) || '/';
- }
- 1;
- }
-
-
- sub _perl_abs_path
- {
- my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
- unless (@cst = stat( $start ))
- {
- _carp("stat($start): $!");
- return '';
- }
-
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
- # NOTE that this routine assumes that '/' is the only directory separator.
-
- my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
- or return cwd() . '/' . $start;
-
- # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
- if (-l $start) {
- my $link_target = readlink($start);
- die "Can't resolve link $start: $!" unless defined $link_target;
-
- require File::Spec;
- $link_target = $dir . '/' . $link_target
- unless File::Spec->file_name_is_absolute($link_target);
-
- return abs_path($link_target);
- }
-
- return $dir ? abs_path($dir) . "/$file" : "/$file";
- }
-
- $cwd = '';
- $dotdots = $start;
- do
- {
- $dotdots .= '/..';
- @pst = @cst;
- local *PARENT;
- unless (opendir(PARENT, $dotdots))
- {
- # probably a permissions issue. Try the native command.
- require File::Spec;
- return File::Spec->rel2abs( $start, _backtick_pwd() );
- }
- unless (@cst = stat($dotdots))
- {
- _carp("stat($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
- {
- $dir = undef;
- }
- else
- {
- do
- {
- unless (defined ($dir = readdir(PARENT)))
- {
- _carp("readdir($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
- }
- while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
- $tst[1] != $pst[1]);
- }
- $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
- closedir(PARENT);
- } while (defined $dir);
- chop($cwd) unless $cwd eq '/'; # drop the trailing /
- $cwd;
- }
-
-
- my $Curdir;
- sub fast_abs_path {
- local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
- my $cwd = getcwd();
- require File::Spec;
- my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
-
- # Detaint else we'll explode in taint mode. This is safe because
- # we're not doing anything dangerous with it.
- ($path) = $path =~ /(.*)/s;
- ($cwd) = $cwd =~ /(.*)/s;
-
- unless (-e $path) {
- _croak("$path: No such file or directory");
- }
-
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
-
- my ($vol, $dir, $file) = File::Spec->splitpath($path);
- return File::Spec->catfile($cwd, $path) unless length $dir;
-
- if (-l $path) {
- my $link_target = readlink($path);
- die "Can't resolve link $path: $!" unless defined $link_target;
-
- $link_target = File::Spec->catpath($vol, $dir, $link_target)
- unless File::Spec->file_name_is_absolute($link_target);
-
- return fast_abs_path($link_target);
- }
-
- return $dir eq File::Spec->rootdir
- ? File::Spec->catpath($vol, $dir, $file)
- : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
- }
-
- if (!CORE::chdir($path)) {
- _croak("Cannot chdir to $path: $!");
- }
- my $realpath = getcwd();
- if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
- _croak("Cannot chdir back to $cwd: $!");
- }
- $realpath;
- }
-
- # added function alias to follow principle of least surprise
- # based on previous aliasing. --tchrist 27-Jan-00
- *fast_realpath = \&fast_abs_path;
-
-
- # --- PORTING SECTION ---
-
- # VMS: $ENV{'DEFAULT'} points to default directory at all times
- # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
- # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
- # in the process logical name table as the default device and directory
- # seen by Perl. This may not be the same as the default device
- # and directory seen by DCL after Perl exits, since the effects
- # the CRTL chdir() function persist only until Perl exits.
-
- sub _vms_cwd {
- return $ENV{'DEFAULT'};
- }
-
- sub _vms_abs_path {
- return $ENV{'DEFAULT'} unless @_;
- my $path = shift;
-
- my $efs = _vms_efs;
- my $unix_rpt = _vms_unix_rpt;
-
- if (defined &VMS::Filespec::vmsrealpath) {
- my $path_unix = 0;
- my $path_vms = 0;
-
- $path_unix = 1 if ($path =~ m#(?<=\^)/#);
- $path_unix = 1 if ($path =~ /^\.\.?$/);
- $path_vms = 1 if ($path =~ m#[\[<\]]#);
- $path_vms = 1 if ($path =~ /^--?$/);
-
- my $unix_mode = $path_unix;
- if ($efs) {
- # In case of a tie, the Unix report mode decides.
- if ($path_vms == $path_unix) {
- $unix_mode = $unix_rpt;
- } else {
- $unix_mode = 0 if $path_vms;
- }
- }
-
- if ($unix_mode) {
- # Unix format
- return VMS::Filespec::unixrealpath($path);
- }
-
- # VMS format
-
- my $new_path = VMS::Filespec::vmsrealpath($path);
-
- # Perl expects directories to be in directory format
- $new_path = VMS::Filespec::pathify($new_path) if -d $path;
- return $new_path;
- }
-
- # Fallback to older algorithm if correct ones are not
- # available.
-
- if (-l $path) {
- my $link_target = readlink($path);
- die "Can't resolve link $path: $!" unless defined $link_target;
-
- return _vms_abs_path($link_target);
- }
-
- # may need to turn foo.dir into [.foo]
- my $pathified = VMS::Filespec::pathify($path);
- $path = $pathified if defined $pathified;
-
- return VMS::Filespec::rmsexpand($path);
- }
-
- sub _os2_cwd {
- $ENV{'PWD'} = `cmd /c cd`;
- chomp $ENV{'PWD'};
- $ENV{'PWD'} =~ s:\\:/:g ;
- return $ENV{'PWD'};
- }
-
- sub _win32_cwd_simple {
- $ENV{'PWD'} = `cd`;
- chomp $ENV{'PWD'};
- $ENV{'PWD'} =~ s:\\:/:g ;
- return $ENV{'PWD'};
- }
-
- sub _win32_cwd {
- # Need to avoid taking any sort of reference to the typeglob or the code in
- # the optree, so that this tests the runtime state of things, as the
- # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
- # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
- # lookup avoids needing a string eval, which has been reported to cause
- # problems (for reasons that we haven't been able to get to the bottom of -
- # rt.cpan.org #56225)
- if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
- $ENV{'PWD'} = Win32::GetCwd();
- }
- else { # miniperl
- chomp($ENV{'PWD'} = `cd`);
- }
- $ENV{'PWD'} =~ s:\\:/:g ;
- return $ENV{'PWD'};
- }
-
- *_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
-
- sub _dos_cwd {
- if (!defined &Dos::GetCwd) {
- $ENV{'PWD'} = `command /c cd`;
- chomp $ENV{'PWD'};
- $ENV{'PWD'} =~ s:\\:/:g ;
- } else {
- $ENV{'PWD'} = Dos::GetCwd();
- }
- return $ENV{'PWD'};
- }
-
- sub _qnx_cwd {
- local $ENV{PATH} = '';
- local $ENV{CDPATH} = '';
- local $ENV{ENV} = '';
- $ENV{'PWD'} = `/usr/bin/fullpath -t`;
- chomp $ENV{'PWD'};
- return $ENV{'PWD'};
- }
-
- sub _qnx_abs_path {
- local $ENV{PATH} = '';
- local $ENV{CDPATH} = '';
- local $ENV{ENV} = '';
- my $path = @_ ? shift : '.';
- local *REALPATH;
-
- defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
- die "Can't open /usr/bin/fullpath: $!";
- my $realpath = <REALPATH>;
- close REALPATH;
- chomp $realpath;
- return $realpath;
- }
-
- sub _epoc_cwd {
- $ENV{'PWD'} = EPOC::getcwd();
- return $ENV{'PWD'};
- }
-
-
- # Now that all the base-level functions are set up, alias the
- # user-level functions to the right places
-
- if (exists $METHOD_MAP{$^O}) {
- my $map = $METHOD_MAP{$^O};
- foreach my $name (keys %$map) {
- local $^W = 0; # assignments trigger 'subroutine redefined' warning
- no strict 'refs';
- *{$name} = \&{$map->{$name}};
- }
- }
-
- # In case the XS version doesn't load.
- *abs_path = \&_perl_abs_path unless defined &abs_path;
- *getcwd = \&_perl_getcwd unless defined &getcwd;
-
- # added function alias for those of us more
- # used to the libc function. --tchrist 27-Jan-00
- *realpath = \&abs_path;
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_CWD
-
-$fatpacked{"x86_64-linux-gnu-thread-multi/Devel/GlobalDestruction/XS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_DEVEL_GLOBALDESTRUCTION_XS';
- package Devel::GlobalDestruction::XS;
- use strict;
- use warnings;
-
- our $VERSION = '0.01';
-
- require XSLoader;
- XSLoader::load(__PACKAGE__, $VERSION);
-
- 1; # keep require happy
-
- __END__
-
- =head1 NAME
-
- Devel::GlobalDestruction::XS - Faster implementation of the Devel::GlobalDestruction API
-
- =head1 SYNOPSIS
-
- use Devel::GlobalDestruction;
-
- =head1 DESCRIPTION
-
- This is an XS backend for L<Devel::GlobalDestruction> and should be used through that module.
-
- =head1 AUTHORS
-
- Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
-
- Florian Ragwitz E<lt>rafl@debian.orgE<gt>
-
- Jesse Luehrs E<lt>doy@tozt.netE<gt>
-
- Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
-
- Arthur Axel 'fREW' Schmidt E<lt>frioux@gmail.comE<gt>
-
- Elizabeth Mattijsen E<lt>liz@dijkmat.nlE<gt>
-
- Graham Knop E<lt>haarg@haarg.orgE<gt>
-
- =head1 COPYRIGHT
-
- Copyright (c) 2008 - 2013 the Devel::GlobalDestruction::XS L</AUTHORS> as listed
- above.
-
- =head1 LICENSE
-
- This library is free software and may be distributed under the same terms
- as perl itself.
-
- =cut
-X86_64-LINUX-GNU-THREAD-MULTI_DEVEL_GLOBALDESTRUCTION_XS
-
-$fatpacked{"File/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC';
- package File::Spec;
-
- use strict;
- use vars qw(@ISA $VERSION);
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- my %module = (MacOS => 'Mac',
- MSWin32 => 'Win32',
- os2 => 'OS2',
- VMS => 'VMS',
- epoc => 'Epoc',
- NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
- symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
- dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
- cygwin => 'Cygwin');
-
-
- my $module = $module{$^O} || 'Unix';
-
- require "File/Spec/$module.pm";
- @ISA = ("File::Spec::$module");
-
- 1;
-
- __END__
-
- =head1 NAME
-
- File::Spec - portably perform operations on file names
-
- =head1 SYNOPSIS
-
- use File::Spec;
-
- $x=File::Spec->catfile('a', 'b', 'c');
-
- which returns 'a/b/c' under Unix. Or:
-
- use File::Spec::Functions;
-
- $x = catfile('a', 'b', 'c');
-
- =head1 DESCRIPTION
-
- This module is designed to support operations commonly performed on file
- specifications (usually called "file names", but not to be confused with the
- contents of a file, or Perl's file handles), such as concatenating several
- directory and file names into a single path, or determining whether a path
- is rooted. It is based on code directly taken from MakeMaker 5.17, code
- written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
- Zakharevich, Paul Schinder, and others.
-
- Since these functions are different for most operating systems, each set of
- OS specific routines is available in a separate module, including:
-
- File::Spec::Unix
- File::Spec::Mac
- File::Spec::OS2
- File::Spec::Win32
- File::Spec::VMS
-
- The module appropriate for the current OS is automatically loaded by
- File::Spec. Since some modules (like VMS) make use of facilities available
- only under that OS, it may not be possible to load all modules under all
- operating systems.
-
- Since File::Spec is object oriented, subroutines should not be called directly,
- as in:
-
- File::Spec::catfile('a','b');
-
- but rather as class methods:
-
- File::Spec->catfile('a','b');
-
- For simple uses, L<File::Spec::Functions> provides convenient functional
- forms of these methods.
-
- =head1 METHODS
-
- =over 2
-
- =item canonpath
- X<canonpath>
-
- No physical check on the filesystem, but a logical cleanup of a
- path.
-
- $cpath = File::Spec->canonpath( $path ) ;
-
- Note that this does *not* collapse F<x/../y> sections into F<y>. This
- is by design. If F</foo> on your system is a symlink to F</bar/baz>,
- then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
- F<../>-removal would give you. If you want to do this kind of
- processing, you probably want C<Cwd>'s C<realpath()> function to
- actually traverse the filesystem cleaning up paths like this.
-
- =item catdir
- X<catdir>
-
- Concatenate two or more directory names to form a complete path ending
- with a directory. But remove the trailing slash from the resulting
- string, because it doesn't look good, isn't necessary and confuses
- OS/2. Of course, if this is the root directory, don't cut off the
- trailing slash :-)
-
- $path = File::Spec->catdir( @directories );
-
- =item catfile
- X<catfile>
-
- Concatenate one or more directory names and a filename to form a
- complete path ending with a filename
-
- $path = File::Spec->catfile( @directories, $filename );
-
- =item curdir
- X<curdir>
-
- Returns a string representation of the current directory.
-
- $curdir = File::Spec->curdir();
-
- =item devnull
- X<devnull>
-
- Returns a string representation of the null device.
-
- $devnull = File::Spec->devnull();
-
- =item rootdir
- X<rootdir>
-
- Returns a string representation of the root directory.
-
- $rootdir = File::Spec->rootdir();
-
- =item tmpdir
- X<tmpdir>
-
- Returns a string representation of the first writable directory from a
- list of possible temporary directories. Returns the current directory
- if no writable temporary directories are found. The list of directories
- checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
- (unless taint is on) and F</tmp>.
-
- $tmpdir = File::Spec->tmpdir();
-
- =item updir
- X<updir>
-
- Returns a string representation of the parent directory.
-
- $updir = File::Spec->updir();
-
- =item no_upwards
-
- Given a list of file names, strip out those that refer to a parent
- directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
- @paths = File::Spec->no_upwards( @paths );
-
- =item case_tolerant
-
- Returns a true or false value indicating, respectively, that alphabetic
- case is not or is significant when comparing file specifications.
- Cygwin and Win32 accept an optional drive argument.
-
- $is_case_tolerant = File::Spec->case_tolerant();
-
- =item file_name_is_absolute
-
- Takes as its argument a path, and returns true if it is an absolute path.
-
- $is_absolute = File::Spec->file_name_is_absolute( $path );
-
- This does not consult the local filesystem on Unix, Win32, OS/2, or
- Mac OS (Classic). It does consult the working environment for VMS
- (see L<File::Spec::VMS/file_name_is_absolute>).
-
- =item path
- X<path>
-
- Takes no argument. Returns the environment variable C<PATH> (or the local
- platform's equivalent) as a list.
-
- @PATH = File::Spec->path();
-
- =item join
- X<join, path>
-
- join is the same as catfile.
-
- =item splitpath
- X<splitpath> X<split, path>
-
- Splits a path in to volume, directory, and filename portions. On systems
- with no concept of volume, returns '' for volume.
-
- ($volume,$directories,$file) =
- File::Spec->splitpath( $path );
- ($volume,$directories,$file) =
- File::Spec->splitpath( $path, $no_file );
-
- For systems with no syntax differentiating filenames from directories,
- assumes that the last file is a path unless C<$no_file> is true or a
- trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
- true makes this return ( '', $path, '' ).
-
- The directory portion may or may not be returned with a trailing '/'.
-
- The results can be passed to L</catpath()> to get back a path equivalent to
- (usually identical to) the original path.
-
- =item splitdir
- X<splitdir> X<split, dir>
-
- The opposite of L</catdir>.
-
- @dirs = File::Spec->splitdir( $directories );
-
- C<$directories> must be only the directory portion of the path on systems
- that have the concept of a volume or that have path syntax that differentiates
- files from directories.
-
- Unlike just splitting the directories on the separator, empty
- directory names (C<''>) can be returned, because these are significant
- on some OSes.
-
- =item catpath()
-
- Takes volume, directory and file portions and returns an entire path. Under
- Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
- inserted if need be. On other OSes, C<$volume> is significant.
-
- $full_path = File::Spec->catpath( $volume, $directory, $file );
-
- =item abs2rel
- X<abs2rel> X<absolute, path> X<relative, path>
-
- Takes a destination path and an optional base path returns a relative path
- from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
- If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
- relative, then it is converted to absolute form using
- L</rel2abs()>. This means that it is taken to be relative to
- L<Cwd::cwd()|Cwd>.
-
- On systems with the concept of volume, if C<$path> and C<$base> appear to be
- on two different volumes, we will not attempt to resolve the two
- paths, and we will instead simply return C<$path>. Note that previous
- versions of this module ignored the volume of C<$base>, which resulted in
- garbage results part of the time.
-
- On systems that have a grammar that indicates filenames, this ignores the
- C<$base> filename as well. Otherwise all path components are assumed to be
- directories.
-
- If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
- This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
-
- No checks against the filesystem are made. On VMS, there is
- interaction with the working environment, as logicals and
- macros are expanded.
-
- Based on code written by Shigio Yamaguchi.
-
- =item rel2abs()
- X<rel2abs> X<absolute, path> X<relative, path>
-
- Converts a relative path to an absolute path.
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
- If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
- then it is converted to absolute form using L</rel2abs()>. This means that it
- is taken to be relative to L<Cwd::cwd()|Cwd>.
-
- On systems with the concept of volume, if C<$path> and C<$base> appear to be
- on two different volumes, we will not attempt to resolve the two
- paths, and we will instead simply return C<$path>. Note that previous
- versions of this module ignored the volume of C<$base>, which resulted in
- garbage results part of the time.
-
- On systems that have a grammar that indicates filenames, this ignores the
- C<$base> filename as well. Otherwise all path components are assumed to be
- directories.
-
- If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
-
- No checks against the filesystem are made. On VMS, there is
- interaction with the working environment, as logicals and
- macros are expanded.
-
- Based on code written by Shigio Yamaguchi.
-
- =back
-
- For further information, please see L<File::Spec::Unix>,
- L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
- L<File::Spec::VMS>.
-
- =head1 SEE ALSO
-
- L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
- L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
- L<ExtUtils::MakeMaker>
-
- =head1 AUTHOR
-
- Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
-
- The vast majority of the code was written by
- Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
- Andy Dougherty C<< <doughera@lafayette.edu> >>,
- Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
- Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
- VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
- OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
- Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
- Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
- abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
- modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
- splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004-2013 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =cut
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC
-
-$fatpacked{"File/Spec/Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_CYGWIN';
- package File::Spec::Cygwin;
-
- use strict;
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- @ISA = qw(File::Spec::Unix);
-
- =head1 NAME
-
- File::Spec::Cygwin - methods for Cygwin file specs
-
- =head1 SYNOPSIS
-
- require File::Spec::Cygwin; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- This module is still in beta. Cygwin-knowledgeable folks are invited
- to offer patches and suggestions.
-
- =cut
-
- =pod
-
- =over 4
-
- =item canonpath
-
- Any C<\> (backslashes) are converted to C</> (forward slashes),
- and then File::Spec::Unix canonpath() is called on the result.
-
- =cut
-
- sub canonpath {
- my($self,$path) = @_;
- return unless defined $path;
-
- $path =~ s|\\|/|g;
-
- # Handle network path names beginning with double slash
- my $node = '';
- if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
- $node = $1;
- }
- return $node . $self->SUPER::canonpath($path);
- }
-
- sub catdir {
- my $self = shift;
- return unless @_;
-
- # Don't create something that looks like a //network/path
- if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
- shift;
- return $self->SUPER::catdir('', @_);
- }
-
- $self->SUPER::catdir(@_);
- }
-
- =pod
-
- =item file_name_is_absolute
-
- True is returned if the file name begins with C<drive_letter:>,
- and if not, File::Spec::Unix file_name_is_absolute() is called.
-
- =cut
-
-
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
- return $self->SUPER::file_name_is_absolute($file);
- }
-
- =item tmpdir (override)
-
- Returns a string representation of the first existing directory
- from the following list:
-
- $ENV{TMPDIR}
- /tmp
- $ENV{'TMP'}
- $ENV{'TEMP'}
- C:/temp
-
- If running under taint mode, and if the environment
- variables are tainted, they are not used.
-
- =cut
-
- sub tmpdir {
- my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TMP TEMP');
- return $cached if defined $cached;
- $_[0]->_cache_tmpdir(
- $_[0]->_tmpdir(
- $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp'
- ),
- qw 'TMPDIR TMP TEMP'
- );
- }
-
- =item case_tolerant
-
- Override Unix. Cygwin case-tolerance depends on managed mount settings and
- as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
- indicating the case significance when comparing file specifications.
- Default: 1
-
- =cut
-
- sub case_tolerant {
- return 1 unless $^O eq 'cygwin'
- and defined &Cygwin::mount_flags;
-
- my $drive = shift;
- if (! $drive) {
- my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
- my $prefix = pop(@flags);
- if (! $prefix || $prefix eq 'cygdrive') {
- $drive = '/cygdrive/c';
- } elsif ($prefix eq '/') {
- $drive = '/c';
- } else {
- $drive = "$prefix/c";
- }
- }
- my $mntopts = Cygwin::mount_flags($drive);
- if ($mntopts and ($mntopts =~ /,managed/)) {
- return 0;
- }
- eval { require Win32API::File; } or return 1;
- my $osFsType = "\0"x256;
- my $osVolName = "\0"x256;
- my $ouFsFlags = 0;
- Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
- if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
- else { return 1; }
- }
-
- =back
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =cut
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_CYGWIN
-
-$fatpacked{"File/Spec/Epoc.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_EPOC';
- package File::Spec::Epoc;
-
- use strict;
- use vars qw($VERSION @ISA);
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- require File::Spec::Unix;
- @ISA = qw(File::Spec::Unix);
-
- =head1 NAME
-
- File::Spec::Epoc - methods for Epoc file specs
-
- =head1 SYNOPSIS
-
- require File::Spec::Epoc; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- See File::Spec::Unix for a documentation of the methods provided
- there. This package overrides the implementation of these methods, not
- the semantics.
-
- This package is still a work in progress. ;-)
-
- =cut
-
- sub case_tolerant {
- return 1;
- }
-
- =pod
-
- =over 4
-
- =item canonpath()
-
- No physical check on the filesystem, but a logical cleanup of a
- path. On UNIX eliminated successive slashes and successive "/.".
-
- =back
-
- =cut
-
- sub canonpath {
- my ($self,$path) = @_;
- return unless defined $path;
-
- $path =~ s|/+|/|g; # xx////xx -> xx/xx
- $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
- $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx
- $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
- return $path;
- }
-
- =pod
-
- =head1 AUTHOR
-
- o.flebbe@gmx.de
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =head1 SEE ALSO
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- =cut
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_EPOC
-
-$fatpacked{"File/Spec/Functions.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_FUNCTIONS';
- package File::Spec::Functions;
-
- use File::Spec;
- use strict;
-
- use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- require Exporter;
-
- @ISA = qw(Exporter);
-
- @EXPORT = qw(
- canonpath
- catdir
- catfile
- curdir
- rootdir
- updir
- no_upwards
- file_name_is_absolute
- path
- );
-
- @EXPORT_OK = qw(
- devnull
- tmpdir
- splitpath
- splitdir
- catpath
- abs2rel
- rel2abs
- case_tolerant
- );
-
- %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
-
- require File::Spec::Unix;
- my %udeps = (
- canonpath => [],
- catdir => [qw(canonpath)],
- catfile => [qw(canonpath catdir)],
- case_tolerant => [],
- curdir => [],
- devnull => [],
- rootdir => [],
- updir => [],
- );
-
- foreach my $meth (@EXPORT, @EXPORT_OK) {
- my $sub = File::Spec->can($meth);
- no strict 'refs';
- if (exists($udeps{$meth}) && $sub == File::Spec::Unix->can($meth) &&
- !(grep {
- File::Spec->can($_) != File::Spec::Unix->can($_)
- } @{$udeps{$meth}}) &&
- defined(&{"File::Spec::Unix::_fn_$meth"})) {
- *{$meth} = \&{"File::Spec::Unix::_fn_$meth"};
- } else {
- *{$meth} = sub {&$sub('File::Spec', @_)};
- }
- }
-
-
- 1;
- __END__
-
- =head1 NAME
-
- File::Spec::Functions - portably perform operations on file names
-
- =head1 SYNOPSIS
-
- use File::Spec::Functions;
- $x = catfile('a','b');
-
- =head1 DESCRIPTION
-
- This module exports convenience functions for all of the class methods
- provided by File::Spec.
-
- For a reference of available functions, please consult L<File::Spec::Unix>,
- which contains the entire set, and which is inherited by the modules for
- other platforms. For further information, please see L<File::Spec::Mac>,
- L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
-
- =head2 Exports
-
- The following functions are exported by default.
-
- canonpath
- catdir
- catfile
- curdir
- rootdir
- updir
- no_upwards
- file_name_is_absolute
- path
-
-
- The following functions are exported only by request.
-
- devnull
- tmpdir
- splitpath
- splitdir
- catpath
- abs2rel
- rel2abs
- case_tolerant
-
- All the functions may be imported using the C<:ALL> tag.
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =head1 SEE ALSO
-
- File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2,
- File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker
-
- =cut
-
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_FUNCTIONS
-
-$fatpacked{"File/Spec/Mac.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_MAC';
- package File::Spec::Mac;
-
- use strict;
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- @ISA = qw(File::Spec::Unix);
-
- my $macfiles;
- if ($^O eq 'MacOS') {
- $macfiles = eval { require Mac::Files };
- }
-
- sub case_tolerant { 1 }
-
-
- =head1 NAME
-
- File::Spec::Mac - File::Spec for Mac OS (Classic)
-
- =head1 SYNOPSIS
-
- require File::Spec::Mac; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- Methods for manipulating file specifications.
-
- =head1 METHODS
-
- =over 2
-
- =item canonpath
-
- On Mac OS, there's nothing to be done. Returns what it's given.
-
- =cut
-
- sub canonpath {
- my ($self,$path) = @_;
- return $path;
- }
-
- =item catdir()
-
- Concatenate two or more directory names to form a path separated by colons
- (":") ending with a directory. Resulting paths are B<relative> by default,
- but can be forced to be absolute (but avoid this, see below). Automatically
- puts a trailing ":" on the end of the complete path, because that's what's
- done in MacPerl's environment and helps to distinguish a file path from a
- directory path.
-
- B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting
- path is relative by default and I<not> absolute. This decision was made due
- to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths
- on all other operating systems, it will now also follow this convention on Mac
- OS. Note that this may break some existing scripts.
-
- The intended purpose of this routine is to concatenate I<directory names>.
- But because of the nature of Macintosh paths, some additional possibilities
- are allowed to make using this routine give reasonable results for some
- common situations. In other words, you are also allowed to concatenate
- I<paths> instead of directory names (strictly speaking, a string like ":a"
- is a path, but not a name, since it contains a punctuation character ":").
-
- So, beside calls like
-
- catdir("a") = ":a:"
- catdir("a","b") = ":a:b:"
- catdir() = "" (special case)
-
- calls like the following
-
- catdir(":a:") = ":a:"
- catdir(":a","b") = ":a:b:"
- catdir(":a:","b") = ":a:b:"
- catdir(":a:",":b:") = ":a:b:"
- catdir(":") = ":"
-
- are allowed.
-
- Here are the rules that are used in C<catdir()>; note that we try to be as
- compatible as possible to Unix:
-
- =over 2
-
- =item 1.
-
- The resulting path is relative by default, i.e. the resulting path will have a
- leading colon.
-
- =item 2.
-
- A trailing colon is added automatically to the resulting path, to denote a
- directory.
-
- =item 3.
-
- Generally, each argument has one leading ":" and one trailing ":"
- removed (if any). They are then joined together by a ":". Special
- treatment applies for arguments denoting updir paths like "::lib:",
- see (4), or arguments consisting solely of colons ("colon paths"),
- see (5).
-
- =item 4.
-
- When an updir path like ":::lib::" is passed as argument, the number
- of directories to climb up is handled correctly, not removing leading
- or trailing colons when necessary. E.g.
-
- catdir(":::a","::b","c") = ":::a::b:c:"
- catdir(":::a::","::b","c") = ":::a:::b:c:"
-
- =item 5.
-
- Adding a colon ":" or empty string "" to a path at I<any> position
- doesn't alter the path, i.e. these arguments are ignored. (When a ""
- is passed as the first argument, it has a special meaning, see
- (6)). This way, a colon ":" is handled like a "." (curdir) on Unix,
- while an empty string "" is generally ignored (see
- C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".."
- (updir), and a ":::" is handled like a "../.." etc. E.g.
-
- catdir("a",":",":","b") = ":a:b:"
- catdir("a",":","::",":b") = ":a::b:"
-
- =item 6.
-
- If the first argument is an empty string "" or is a volume name, i.e. matches
- the pattern /^[^:]+:/, the resulting path is B<absolute>.
-
- =item 7.
-
- Passing an empty string "" as the first argument to C<catdir()> is
- like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e.
-
- catdir("","a","b") is the same as
-
- catdir(rootdir(),"a","b").
-
- This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and
- C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup
- volume, which is the closest in concept to Unix' "/". This should help
- to run existing scripts originally written for Unix.
-
- =item 8.
-
- For absolute paths, some cleanup is done, to ensure that the volume
- name isn't immediately followed by updirs. This is invalid, because
- this would go beyond "root". Generally, these cases are handled like
- their Unix counterparts:
-
- Unix:
- Unix->catdir("","") = "/"
- Unix->catdir("",".") = "/"
- Unix->catdir("","..") = "/" # can't go
- # beyond root
- Unix->catdir("",".","..","..","a") = "/a"
- Mac:
- Mac->catdir("","") = rootdir() # (e.g. "HD:")
- Mac->catdir("",":") = rootdir()
- Mac->catdir("","::") = rootdir() # can't go
- # beyond root
- Mac->catdir("",":","::","::","a") = rootdir() . "a:"
- # (e.g. "HD:a:")
-
- However, this approach is limited to the first arguments following
- "root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
- arguments that move up the directory tree, an invalid path going
- beyond root can be created.
-
- =back
-
- As you've seen, you can force C<catdir()> to create an absolute path
- by passing either an empty string or a path that begins with a volume
- name as the first argument. However, you are strongly encouraged not
- to do so, since this is done only for backward compatibility. Newer
- versions of File::Spec come with a method called C<catpath()> (see
- below), that is designed to offer a portable solution for the creation
- of absolute paths. It takes volume, directory and file portions and
- returns an entire path. While C<catdir()> is still suitable for the
- concatenation of I<directory names>, you are encouraged to use
- C<catpath()> to concatenate I<volume names> and I<directory
- paths>. E.g.
-
- $dir = File::Spec->catdir("tmp","sources");
- $abs_path = File::Spec->catpath("MacintoshHD:", $dir,"");
-
- yields
-
- "MacintoshHD:tmp:sources:" .
-
- =cut
-
- sub catdir {
- my $self = shift;
- return '' unless @_;
- my @args = @_;
- my $first_arg;
- my $relative;
-
- # take care of the first argument
-
- if ($args[0] eq '') { # absolute path, rootdir
- shift @args;
- $relative = 0;
- $first_arg = $self->rootdir;
-
- } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name
- $relative = 0;
- $first_arg = shift @args;
- # add a trailing ':' if need be (may be it's a path like HD:dir)
- $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
-
- } else { # relative path
- $relative = 1;
- if ( $args[0] =~ /^::+\Z(?!\n)/ ) {
- # updir colon path ('::', ':::' etc.), don't shift
- $first_arg = ':';
- } elsif ($args[0] eq ':') {
- $first_arg = shift @args;
- } else {
- # add a trailing ':' if need be
- $first_arg = shift @args;
- $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/);
- }
- }
-
- # For all other arguments,
- # (a) ignore arguments that equal ':' or '',
- # (b) handle updir paths specially:
- # '::' -> concatenate '::'
- # '::' . '::' -> concatenate ':::' etc.
- # (c) add a trailing ':' if need be
-
- my $result = $first_arg;
- while (@args) {
- my $arg = shift @args;
- unless (($arg eq '') || ($arg eq ':')) {
- if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::'
- my $updir_count = length($arg) - 1;
- while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path
- $arg = shift @args;
- $updir_count += (length($arg) - 1);
- }
- $arg = (':' x $updir_count);
- } else {
- $arg =~ s/^://s; # remove a leading ':' if any
- $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':'
- }
- $result .= $arg;
- }#unless
- }
-
- if ( ($relative) && ($result !~ /^:/) ) {
- # add a leading colon if need be
- $result = ":$result";
- }
-
- unless ($relative) {
- # remove updirs immediately following the volume name
- $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/;
- }
-
- return $result;
- }
-
- =item catfile
-
- Concatenate one or more directory names and a filename to form a
- complete path ending with a filename. Resulting paths are B<relative>
- by default, but can be forced to be absolute (but avoid this).
-
- B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the
- resulting path is relative by default and I<not> absolute. This
- decision was made due to portability reasons. Since
- C<File::Spec-E<gt>catfile()> returns relative paths on all other
- operating systems, it will now also follow this convention on Mac OS.
- Note that this may break some existing scripts.
-
- The last argument is always considered to be the file portion. Since
- C<catfile()> uses C<catdir()> (see above) for the concatenation of the
- directory portions (if any), the following with regard to relative and
- absolute paths is true:
-
- catfile("") = ""
- catfile("file") = "file"
-
- but
-
- catfile("","") = rootdir() # (e.g. "HD:")
- catfile("","file") = rootdir() . file # (e.g. "HD:file")
- catfile("HD:","file") = "HD:file"
-
- This means that C<catdir()> is called only when there are two or more
- arguments, as one might expect.
-
- Note that the leading ":" is removed from the filename, so that
-
- catfile("a","b","file") = ":a:b:file" and
-
- catfile("a","b",":file") = ":a:b:file"
-
- give the same answer.
-
- To concatenate I<volume names>, I<directory paths> and I<filenames>,
- you are encouraged to use C<catpath()> (see below).
-
- =cut
-
- sub catfile {
- my $self = shift;
- return '' unless @_;
- my $file = pop @_;
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $file =~ s/^://s;
- return $dir.$file;
- }
-
- =item curdir
-
- Returns a string representing the current directory. On Mac OS, this is ":".
-
- =cut
-
- sub curdir {
- return ":";
- }
-
- =item devnull
-
- Returns a string representing the null device. On Mac OS, this is "Dev:Null".
-
- =cut
-
- sub devnull {
- return "Dev:Null";
- }
-
- =item rootdir
-
- Returns a string representing the root directory. Under MacPerl,
- returns the name of the startup volume, since that's the closest in
- concept, although other volumes aren't rooted there. The name has a
- trailing ":", because that's the correct specification for a volume
- name on Mac OS.
-
- If Mac::Files could not be loaded, the empty string is returned.
-
- =cut
-
- sub rootdir {
- #
- # There's no real root directory on Mac OS. The name of the startup
- # volume is returned, since that's the closest in concept.
- #
- return '' unless $macfiles;
- my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
- &Mac::Files::kSystemFolderType);
- $system =~ s/:.*\Z(?!\n)/:/s;
- return $system;
- }
-
- =item tmpdir
-
- Returns the contents of $ENV{TMPDIR}, if that directory exits or the
- current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will
- contain a path like "MacintoshHD:Temporary Items:", which is a hidden
- directory on your startup volume.
-
- =cut
-
- sub tmpdir {
- my $cached = $_[0]->_cached_tmpdir('TMPDIR');
- return $cached if defined $cached;
- $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR} ), 'TMPDIR');
- }
-
- =item updir
-
- Returns a string representing the parent directory. On Mac OS, this is "::".
-
- =cut
-
- sub updir {
- return "::";
- }
-
- =item file_name_is_absolute
-
- Takes as argument a path and returns true, if it is an absolute path.
- If the path has a leading ":", it's a relative path. Otherwise, it's an
- absolute path, unless the path doesn't contain any colons, i.e. it's a name
- like "a". In this particular case, the path is considered to be relative
- (i.e. it is considered to be a filename). Use ":" in the appropriate place
- in the path if you want to distinguish unambiguously. As a special case,
- the filename '' is always considered to be absolute. Note that with version
- 1.2 of File::Spec::Mac, this does no longer consult the local filesystem.
-
- E.g.
-
- File::Spec->file_name_is_absolute("a"); # false (relative)
- File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
- File::Spec->file_name_is_absolute("MacintoshHD:");
- # true (absolute)
- File::Spec->file_name_is_absolute(""); # true (absolute)
-
-
- =cut
-
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- if ($file =~ /:/) {
- return (! ($file =~ m/^:/s) );
- } elsif ( $file eq '' ) {
- return 1 ;
- } else {
- return 0; # i.e. a file like "a"
- }
- }
-
- =item path
-
- Returns the null list for the MacPerl application, since the concept is
- usually meaningless under Mac OS. But if you're using the MacPerl tool under
- MPW, it gives back $ENV{Commands} suitably split, as is done in
- :lib:ExtUtils:MM_Mac.pm.
-
- =cut
-
- sub path {
- #
- # The concept is meaningless under the MacPerl application.
- # Under MPW, it has a meaning.
- #
- return unless exists $ENV{Commands};
- return split(/,/, $ENV{Commands});
- }
-
- =item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path,
- $no_file );
-
- Splits a path into volume, directory, and filename portions.
-
- On Mac OS, assumes that the last part of the path is a filename unless
- $no_file is true or a trailing separator ":" is present.
-
- The volume portion is always returned with a trailing ":". The directory portion
- is always returned with a leading (to denote a relative path) and a trailing ":"
- (to denote a directory). The file portion is always returned I<without> a leading ":".
- Empty portions are returned as empty string ''.
-
- The results can be passed to C<catpath()> to get back a path equivalent to
- (usually identical to) the original path.
-
-
- =cut
-
- sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file);
-
- if ( $nofile ) {
- ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s;
- }
- else {
- $path =~
- m|^( (?: [^:]+: )? )
- ( (?: .*: )? )
- ( .* )
- |xs;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- $volume = '' unless defined($volume);
- $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir"
- if ($directory) {
- # Make sure non-empty directories begin and end in ':'
- $directory .= ':' unless (substr($directory,-1) eq ':');
- $directory = ":$directory" unless (substr($directory,0,1) eq ':');
- } else {
- $directory = '';
- }
- $file = '' unless defined($file);
-
- return ($volume,$directory,$file);
- }
-
-
- =item splitdir
-
- The opposite of C<catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
- $directories should be only the directory portion of the path on systems
- that have the concept of a volume or that have path syntax that differentiates
- files from directories. Consider using C<splitpath()> otherwise.
-
- Unlike just splitting the directories on the separator, empty directory names
- (C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing
- colon to distinguish a directory path from a file path, a single trailing colon
- will be ignored, i.e. there's no empty directory name after it.
-
- Hence, on Mac OS, both
-
- File::Spec->splitdir( ":a:b::c:" ); and
- File::Spec->splitdir( ":a:b::c" );
-
- yield:
-
- ( "a", "b", "::", "c")
-
- while
-
- File::Spec->splitdir( ":a:b::c::" );
-
- yields:
-
- ( "a", "b", "::", "c", "::")
-
-
- =cut
-
- sub splitdir {
- my ($self, $path) = @_;
- my @result = ();
- my ($head, $sep, $tail, $volume, $directories);
-
- return @result if ( (!defined($path)) || ($path eq '') );
- return (':') if ($path eq ':');
-
- ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
-
- # deprecated, but handle it correctly
- if ($volume) {
- push (@result, $volume);
- $sep .= ':';
- }
-
- while ($sep || $directories) {
- if (length($sep) > 1) {
- my $updir_count = length($sep) - 1;
- for (my $i=0; $i<$updir_count; $i++) {
- # push '::' updir_count times;
- # simulate Unix '..' updirs
- push (@result, '::');
- }
- }
- $sep = '';
- if ($directories) {
- ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s;
- push (@result, $head);
- $directories = $tail;
- }
- }
- return @result;
- }
-
-
- =item catpath
-
- $path = File::Spec->catpath($volume,$directory,$file);
-
- Takes volume, directory and file portions and returns an entire path. On Mac OS,
- $volume, $directory and $file are concatenated. A ':' is inserted if need be. You
- may pass an empty string for each portion. If all portions are empty, the empty
- string is returned. If $volume is empty, the result will be a relative path,
- beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any)
- is removed form $file and the remainder is returned. If $file is empty, the
- resulting path will have a trailing ':'.
-
-
- =cut
-
- sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- if ( (! $volume) && (! $directory) ) {
- $file =~ s/^:// if $file;
- return $file ;
- }
-
- # We look for a volume in $volume, then in $directory, but not both
-
- my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
-
- $volume = $dir_volume unless length $volume;
- my $path = $volume; # may be ''
- $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
-
- if ($directory) {
- $directory = $dir_dirs if $volume;
- $directory =~ s/^://; # remove leading ':' if any
- $path .= $directory;
- $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
- }
-
- if ($file) {
- $file =~ s/^://; # remove leading ':' if any
- $path .= $file;
- }
-
- return $path;
- }
-
- =item abs2rel
-
- Takes a destination path and an optional base path and returns a relative path
- from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
- Note that both paths are assumed to have a notation that distinguishes a
- directory path (with trailing ':') from a file path (without trailing ':').
-
- If $base is not present or '', then the current working directory is used.
- If $base is relative, then it is converted to absolute form using C<rel2abs()>.
- This means that it is taken to be relative to the current working directory.
-
- If $path and $base appear to be on two different volumes, we will not
- attempt to resolve the two paths, and we will instead simply return
- $path. Note that previous versions of this module ignored the volume
- of $base, which resulted in garbage results part of the time.
-
- If $base doesn't have a trailing colon, the last element of $base is
- assumed to be a filename. This filename is ignored. Otherwise all path
- components are assumed to be directories.
-
- If $path is relative, it is converted to absolute form using C<rel2abs()>.
- This means that it is taken to be relative to the current working directory.
-
- Based on code written by Shigio Yamaguchi.
-
-
- =cut
-
- # maybe this should be done in canonpath() ?
- sub _resolve_updirs {
- my $path = shift @_;
- my $proceed;
-
- # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file"
- do {
- $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
- } while ($proceed);
-
- return $path;
- }
-
-
- sub abs2rel {
- my($self,$path,$base) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- $base = _resolve_updirs( $base ); # resolve updirs in $base
- }
- else {
- $base = _resolve_updirs( $base );
- }
-
- # Split up paths - ignore $base's file
- my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
- my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
-
- return $path unless lc( $path_vol ) eq lc( $base_vol );
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_dirs );
- my @basechunks = $self->splitdir( $base_dirs );
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # @pathchunks now has the directories to descend in to.
- # ensure relative path, even if @pathchunks is empty
- $path_dirs = $self->catdir( ':', @pathchunks );
-
- # @basechunks now contains the number of directories to climb out of.
- $base_dirs = (':' x @basechunks) . ':' ;
-
- return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ;
- }
-
- =item rel2abs
-
- Converts a relative path to an absolute path:
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
- Note that both paths are assumed to have a notation that distinguishes a
- directory path (with trailing ':') from a file path (without trailing ':').
-
- If $base is not present or '', then $base is set to the current working
- directory. If $base is relative, then it is converted to absolute form
- using C<rel2abs()>. This means that it is taken to be relative to the
- current working directory.
-
- If $base doesn't have a trailing colon, the last element of $base is
- assumed to be a filename. This filename is ignored. Otherwise all path
- components are assumed to be directories.
-
- If $path is already absolute, it is returned and $base is ignored.
-
- Based on code written by Shigio Yamaguchi.
-
- =cut
-
- sub rel2abs {
- my ($self,$path,$base) = @_;
-
- if ( ! $self->file_name_is_absolute($path) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute($base) ) {
- $base = $self->rel2abs($base) ;
- }
-
- # Split up paths
-
- # ignore $path's volume
- my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
-
- # ignore $base's file part
- my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
-
- # Glom them together
- $path_dirs = ':' if ($path_dirs eq '');
- $base_dirs =~ s/:$//; # remove trailing ':', if any
- $base_dirs = $base_dirs . $path_dirs;
-
- $path = $self->catpath( $base_vol, $base_dirs, $path_file );
- }
- return $path;
- }
-
-
- =back
-
- =head1 AUTHORS
-
- See the authors list in I<File::Spec>. Mac OS support by Paul Schinder
- <schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>.
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =head1 SEE ALSO
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- =cut
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_MAC
-
-$fatpacked{"File/Spec/OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_OS2';
- package File::Spec::OS2;
-
- use strict;
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- @ISA = qw(File::Spec::Unix);
-
- sub devnull {
- return "/dev/nul";
- }
-
- sub case_tolerant {
- return 1;
- }
-
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m{^([a-z]:)?[\\/]}is);
- }
-
- sub path {
- my $path = $ENV{PATH};
- $path =~ s:\\:/:g;
- my @path = split(';',$path);
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
- }
-
- sub _cwd {
- # In OS/2 the "require Cwd" is unnecessary bloat.
- return Cwd::sys_cwd();
- }
-
- sub tmpdir {
- my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP');
- return $cached if defined $cached;
- my @d = @ENV{qw(TMPDIR TEMP TMP)}; # function call could autovivivy
- $_[0]->_cache_tmpdir(
- $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP'
- );
- }
-
- sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- tr[\\][/];
- # append a backslash to each argument unless it has one there
- $_ .= "/" unless m{/$};
- }
- return $self->canonpath(join('', @args));
- }
-
- sub canonpath {
- my ($self,$path) = @_;
- return unless defined $path;
-
- $path =~ s/^([a-z]:)/\l$1/s;
- $path =~ s|\\|/|g;
- $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
- $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
- $path =~ s|/\Z(?!\n)||
- unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
- $path =~ s{^/\.\.$}{/}; # /.. -> /
- 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
- return $path;
- }
-
-
- sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file) = ('','','');
- if ( $nofile ) {
- $path =~
- m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- }
- else {
- $path =~
- m{^ ( (?: [a-zA-Z]: |
- (?:\\\\|//)[^\\/]+[\\/][^\\/]+
- )?
- )
- ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
- (.*)
- }xs;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- return ($volume,$directory,$file);
- }
-
-
- sub splitdir {
- my ($self,$directories) = @_ ;
- split m|[\\/]|, $directories, -1;
- }
-
-
- sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- # If it's UNC, make sure the glue separator is there, reusing
- # whatever separator is first in the $volume
- $volume .= $1
- if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
- $directory =~ m@^[^\\/]@s
- ) ;
-
- $volume .= $directory ;
-
- # If the volume is not just A:, make sure the glue separator is
- # there, reusing whatever separator is first in the $volume if possible.
- if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
- $volume =~ m@[^\\/]\Z(?!\n)@ &&
- $file =~ m@[^\\/]@
- ) {
- $volume =~ m@([\\/])@ ;
- my $sep = $1 ? $1 : '/' ;
- $volume .= $sep ;
- }
-
- $volume .= $file ;
-
- return $volume ;
- }
-
-
- sub abs2rel {
- my($self,$path,$base) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- } else {
- $path = $self->canonpath( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- } elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- } else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Split up paths
- my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
- my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
- return $path unless $path_volume eq $base_volume;
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- my @basechunks = $self->splitdir( $base_directories );
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
- ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # No need to catdir, we know these are well formed.
- $path_directories = CORE::join( '/', @pathchunks );
- $base_directories = CORE::join( '/', @basechunks );
-
- # $base_directories now contains the directories the resulting relative
- # path must ascend out of before it can descend to $path_directory. So,
- # replace all names with $parentDir
-
- #FA Need to replace between backslashes...
- $base_directories =~ s|[^\\/]+|..|g ;
-
- # Glue the two together, using a separator if necessary, and preventing an
- # empty result.
-
- #FA Must check that new directories are not empty.
- if ( $path_directories ne '' && $base_directories ne '' ) {
- $path_directories = "$base_directories/$path_directories" ;
- } else {
- $path_directories = "$base_directories$path_directories" ;
- }
-
- return $self->canonpath(
- $self->catpath( "", $path_directories, $path_file )
- ) ;
- }
-
-
- sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- if ( ! $self->file_name_is_absolute( $path ) ) {
-
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path, 1 ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base, 1 ) ;
-
- $path = $self->catpath(
- $base_volume,
- $self->catdir( $base_directories, $path_directories ),
- $path_file
- ) ;
- }
-
- return $self->canonpath( $path ) ;
- }
-
- 1;
- __END__
-
- =head1 NAME
-
- File::Spec::OS2 - methods for OS/2 file specs
-
- =head1 SYNOPSIS
-
- require File::Spec::OS2; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- Amongst the changes made for OS/2 are...
-
- =over 4
-
- =item tmpdir
-
- Modifies the list of places temp directory information is looked for.
-
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- /tmp
- /
-
- =item splitpath
-
- Volumes can be drive letters or UNC sharenames (\\server\share).
-
- =back
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =cut
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_OS2
-
-$fatpacked{"File/Spec/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_UNIX';
- package File::Spec::Unix;
-
- use strict;
- use vars qw($VERSION);
-
- $VERSION = '3.47';
- my $xs_version = $VERSION;
- $VERSION =~ tr/_//;
-
- unless (defined &canonpath) {
- eval {
- if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load("Cwd", $xs_version);
- } else {
- require Cwd;
- }
- };
- }
-
- =head1 NAME
-
- File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
-
- =head1 SYNOPSIS
-
- require File::Spec::Unix; # Done automatically by File::Spec
-
- =head1 DESCRIPTION
-
- Methods for manipulating file specifications. Other File::Spec
- modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
- override specific methods.
-
- =head1 METHODS
-
- =over 2
-
- =item canonpath()
-
- No physical check on the filesystem, but a logical cleanup of a
- path. On UNIX eliminates successive slashes and successive "/.".
-
- $cpath = File::Spec->canonpath( $path ) ;
-
- Note that this does *not* collapse F<x/../y> sections into F<y>. This
- is by design. If F</foo> on your system is a symlink to F</bar/baz>,
- then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
- F<../>-removal would give you. If you want to do this kind of
- processing, you probably want C<Cwd>'s C<realpath()> function to
- actually traverse the filesystem cleaning up paths like this.
-
- =cut
-
- sub _pp_canonpath {
- my ($self,$path) = @_;
- return unless defined $path;
-
- # Handle POSIX-style node names beginning with double slash (qnx, nto)
- # (POSIX says: "a pathname that begins with two successive slashes
- # may be interpreted in an implementation-defined manner, although
- # more than two leading slashes shall be treated as a single slash.")
- my $node = '';
- my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
-
-
- if ( $double_slashes_special
- && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
- $node = $1;
- }
- # This used to be
- # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
- # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
- # (Mainly because trailing "" directories didn't get stripped).
- # Why would cygwin avoid collapsing multiple slashes into one? --jhi
- $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
- $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
- $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
- $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
- $path =~ s|^/\.\.$|/|; # /.. -> /
- $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
- return "$node$path";
- }
- *canonpath = \&_pp_canonpath unless defined &canonpath;
-
- =item catdir()
-
- Concatenate two or more directory names to form a complete path ending
- with a directory. But remove the trailing slash from the resulting
- string, because it doesn't look good, isn't necessary and confuses
- OS2. Of course, if this is the root directory, don't cut off the
- trailing slash :-)
-
- =cut
-
- sub _pp_catdir {
- my $self = shift;
-
- $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
- }
- *catdir = \&_pp_catdir unless defined &catdir;
-
- =item catfile
-
- Concatenate one or more directory names and a filename to form a
- complete path ending with a filename
-
- =cut
-
- sub _pp_catfile {
- my $self = shift;
- my $file = $self->canonpath(pop @_);
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "/" unless substr($dir,-1) eq "/";
- return $dir.$file;
- }
- *catfile = \&_pp_catfile unless defined &catfile;
-
- =item curdir
-
- Returns a string representation of the current directory. "." on UNIX.
-
- =cut
-
- sub curdir { '.' }
- use constant _fn_curdir => ".";
-
- =item devnull
-
- Returns a string representation of the null device. "/dev/null" on UNIX.
-
- =cut
-
- sub devnull { '/dev/null' }
- use constant _fn_devnull => "/dev/null";
-
- =item rootdir
-
- Returns a string representation of the root directory. "/" on UNIX.
-
- =cut
-
- sub rootdir { '/' }
- use constant _fn_rootdir => "/";
-
- =item tmpdir
-
- Returns a string representation of the first writable directory from
- the following list or the current directory if none from the list are
- writable:
-
- $ENV{TMPDIR}
- /tmp
-
- If running under taint mode, and if $ENV{TMPDIR}
- is tainted, it is not used.
-
- =cut
-
- my ($tmpdir, %tmpenv);
- # Cache and return the calculated tmpdir, recording which env vars
- # determined it.
- sub _cache_tmpdir {
- @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
- return $tmpdir = $_[1];
- }
- # Retrieve the cached tmpdir, checking first whether relevant env vars have
- # changed and invalidated the cache.
- sub _cached_tmpdir {
- shift;
- local $^W;
- return if grep $ENV{$_} ne $tmpenv{$_}, @_;
- return $tmpdir;
- }
- sub _tmpdir {
- my $self = shift;
- my @dirlist = @_;
- my $taint = do { no strict 'refs'; ${"\cTAINT"} };
- if ($taint) { # Check for taint mode on perl >= 5.8.0
- require Scalar::Util;
- @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
- }
- elsif ($] < 5.007) { # No ${^TAINT} before 5.8
- @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
- }
-
- foreach (@dirlist) {
- next unless defined && -d && -w _;
- $tmpdir = $_;
- last;
- }
- $tmpdir = $self->curdir unless defined $tmpdir;
- $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
- if ( !$self->file_name_is_absolute($tmpdir) ) {
- # See [perl #120593] for the full details
- # If possible, return a full path, rather than '.' or 'lib', but
- # jump through some hoops to avoid returning a tainted value.
- ($tmpdir) = grep {
- $taint ? ! Scalar::Util::tainted($_) :
- $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
- } $self->rel2abs($tmpdir), $tmpdir;
- }
- return $tmpdir;
- }
-
- sub tmpdir {
- my $cached = $_[0]->_cached_tmpdir('TMPDIR');
- return $cached if defined $cached;
- $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
- }
-
- =item updir
-
- Returns a string representation of the parent directory. ".." on UNIX.
-
- =cut
-
- sub updir { '..' }
- use constant _fn_updir => "..";
-
- =item no_upwards
-
- Given a list of file names, strip out those that refer to a parent
- directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
- =cut
-
- sub no_upwards {
- my $self = shift;
- return grep(!/^\.{1,2}\z/s, @_);
- }
-
- =item case_tolerant
-
- Returns a true or false value indicating, respectively, that alphabetic
- is not or is significant when comparing file specifications.
-
- =cut
-
- sub case_tolerant { 0 }
- use constant _fn_case_tolerant => 0;
-
- =item file_name_is_absolute
-
- Takes as argument a path and returns true if it is an absolute path.
-
- This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
- OS (Classic). It does consult the working environment for VMS (see
- L<File::Spec::VMS/file_name_is_absolute>).
-
- =cut
-
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m:^/:s);
- }
-
- =item path
-
- Takes no argument, returns the environment variable PATH as an array.
-
- =cut
-
- sub path {
- return () unless exists $ENV{PATH};
- my @path = split(':', $ENV{PATH});
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
- }
-
- =item join
-
- join is the same as catfile.
-
- =cut
-
- sub join {
- my $self = shift;
- return $self->catfile(@_);
- }
-
- =item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path,
- $no_file );
-
- Splits a path into volume, directory, and filename portions. On systems
- with no concept of volume, returns '' for volume.
-
- For systems with no syntax differentiating filenames from directories,
- assumes that the last file is a path unless $no_file is true or a
- trailing separator or /. or /.. is present. On Unix this means that $no_file
- true makes this return ( '', $path, '' ).
-
- The directory portion may or may not be returned with a trailing '/'.
-
- The results can be passed to L</catpath()> to get back a path equivalent to
- (usually identical to) the original path.
-
- =cut
-
- sub splitpath {
- my ($self,$path, $nofile) = @_;
-
- my ($volume,$directory,$file) = ('','','');
-
- if ( $nofile ) {
- $directory = $path;
- }
- else {
- $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
- $directory = $1;
- $file = $2;
- }
-
- return ($volume,$directory,$file);
- }
-
-
- =item splitdir
-
- The opposite of L</catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
- $directories must be only the directory portion of the path on systems
- that have the concept of a volume or that have path syntax that differentiates
- files from directories.
-
- Unlike just splitting the directories on the separator, empty
- directory names (C<''>) can be returned, because these are significant
- on some OSs.
-
- On Unix,
-
- File::Spec->splitdir( "/a/b//c/" );
-
- Yields:
-
- ( '', 'a', 'b', '', 'c', '' )
-
- =cut
-
- sub splitdir {
- return split m|/|, $_[1], -1; # Preserve trailing fields
- }
-
-
- =item catpath()
-
- Takes volume, directory and file portions and returns an entire path. Under
- Unix, $volume is ignored, and directory and file are concatenated. A '/' is
- inserted if needed (though if the directory portion doesn't start with
- '/' it is not added). On other OSs, $volume is significant.
-
- =cut
-
- sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- if ( $directory ne '' &&
- $file ne '' &&
- substr( $directory, -1 ) ne '/' &&
- substr( $file, 0, 1 ) ne '/'
- ) {
- $directory .= "/$file" ;
- }
- else {
- $directory .= $file ;
- }
-
- return $directory ;
- }
-
- =item abs2rel
-
- Takes a destination path and an optional base path returns a relative path
- from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
- If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
- relative, then it is converted to absolute form using
- L</rel2abs()>. This means that it is taken to be relative to
- L<cwd()|Cwd>.
-
- On systems that have a grammar that indicates filenames, this ignores the
- $base filename. Otherwise all path components are assumed to be
- directories.
-
- If $path is relative, it is converted to absolute form using L</rel2abs()>.
- This means that it is taken to be relative to L<cwd()|Cwd>.
-
- No checks against the filesystem are made, so the result may not be correct if
- C<$base> contains symbolic links. (Apply
- L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
- is a concern.) On VMS, there is interaction with the working environment, as
- logicals and macros are expanded.
-
- Based on code written by Shigio Yamaguchi.
-
- =cut
-
- sub abs2rel {
- my($self,$path,$base) = @_;
- $base = $self->_cwd() unless defined $base and length $base;
-
- ($path, $base) = map $self->canonpath($_), $path, $base;
-
- my $path_directories;
- my $base_directories;
-
- if (grep $self->file_name_is_absolute($_), $path, $base) {
- ($path, $base) = map $self->rel2abs($_), $path, $base;
-
- my ($path_volume) = $self->splitpath($path, 1);
- my ($base_volume) = $self->splitpath($base, 1);
-
- # Can't relativize across volumes
- return $path unless $path_volume eq $base_volume;
-
- $path_directories = ($self->splitpath($path, 1))[1];
- $base_directories = ($self->splitpath($base, 1))[1];
-
- # For UNC paths, the user might give a volume like //foo/bar that
- # strictly speaking has no directory portion. Treat it as if it
- # had the root directory for that volume.
- if (!length($base_directories) and $self->file_name_is_absolute($base)) {
- $base_directories = $self->rootdir;
- }
- }
- else {
- my $wd= ($self->splitpath($self->_cwd(), 1))[1];
- $path_directories = $self->catdir($wd, $path);
- $base_directories = $self->catdir($wd, $base);
- }
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- my @basechunks = $self->splitdir( $base_directories );
-
- if ($base_directories eq $self->rootdir) {
- return $self->curdir if $path_directories eq $self->rootdir;
- shift @pathchunks;
- return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
- }
-
- my @common;
- while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
- push @common, shift @pathchunks ;
- shift @basechunks ;
- }
- return $self->curdir unless @pathchunks || @basechunks;
-
- # @basechunks now contains the directories the resulting relative path
- # must ascend out of before it can descend to $path_directory. If there
- # are updir components, we must descend into the corresponding directories
- # (this only works if they are no symlinks).
- my @reverse_base;
- while( defined(my $dir= shift @basechunks) ) {
- if( $dir ne $self->updir ) {
- unshift @reverse_base, $self->updir;
- push @common, $dir;
- }
- elsif( @common ) {
- if( @reverse_base && $reverse_base[0] eq $self->updir ) {
- shift @reverse_base;
- pop @common;
- }
- else {
- unshift @reverse_base, pop @common;
- }
- }
- }
- my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
- return $self->canonpath( $self->catpath('', $result_dirs, '') );
- }
-
- sub _same {
- $_[1] eq $_[2];
- }
-
- =item rel2abs()
-
- Converts a relative path to an absolute path.
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
- If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
- relative, then it is converted to absolute form using
- L</rel2abs()>. This means that it is taken to be relative to
- L<cwd()|Cwd>.
-
- On systems that have a grammar that indicates filenames, this ignores
- the $base filename. Otherwise all path components are assumed to be
- directories.
-
- If $path is absolute, it is cleaned up and returned using L</canonpath()>.
-
- No checks against the filesystem are made. On VMS, there is
- interaction with the working environment, as logicals and
- macros are expanded.
-
- Based on code written by Shigio Yamaguchi.
-
- =cut
-
- sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd();
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Glom them together
- $path = $self->catdir( $base, $path ) ;
- }
-
- return $self->canonpath( $path ) ;
- }
-
- =back
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- Please submit bug reports and patches to perlbug@perl.org.
-
- =head1 SEE ALSO
-
- L<File::Spec>
-
- =cut
-
- # Internal routine to File::Spec, no point in making this public since
- # it is the standard Cwd interface. Most of the platform-specific
- # File::Spec subclasses use this.
- sub _cwd {
- require Cwd;
- Cwd::getcwd();
- }
-
-
- # Internal method to reduce xx\..\yy -> yy
- sub _collapse {
- my($fs, $path) = @_;
-
- my $updir = $fs->updir;
- my $curdir = $fs->curdir;
-
- my($vol, $dirs, $file) = $fs->splitpath($path);
- my @dirs = $fs->splitdir($dirs);
- pop @dirs if @dirs && $dirs[-1] eq '';
-
- my @collapsed;
- foreach my $dir (@dirs) {
- if( $dir eq $updir and # if we have an updir
- @collapsed and # and something to collapse
- length $collapsed[-1] and # and its not the rootdir
- $collapsed[-1] ne $updir and # nor another updir
- $collapsed[-1] ne $curdir # nor the curdir
- )
- { # then
- pop @collapsed; # collapse
- }
- else { # else
- push @collapsed, $dir; # just hang onto it
- }
- }
-
- return $fs->catpath($vol,
- $fs->catdir(@collapsed),
- $file
- );
- }
-
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_UNIX
-
-$fatpacked{"File/Spec/VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_VMS';
- package File::Spec::VMS;
-
- use strict;
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- @ISA = qw(File::Spec::Unix);
-
- use File::Basename;
- use VMS::Filespec;
-
- =head1 NAME
-
- File::Spec::VMS - methods for VMS file specs
-
- =head1 SYNOPSIS
-
- require File::Spec::VMS; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- See File::Spec::Unix for a documentation of the methods provided
- there. This package overrides the implementation of these methods, not
- the semantics.
-
- The default behavior is to allow either VMS or Unix syntax on input and to
- return VMS syntax on output unless Unix syntax has been explicitly requested
- via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
-
- =over 4
-
- =cut
-
- # Need to look up the feature settings. The preferred way is to use the
- # VMS::Feature module, but that may not be available to dual life modules.
-
- my $use_feature;
- BEGIN {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $use_feature = 1;
- }
- }
-
- # Need to look up the UNIX report mode. This may become a dynamic mode
- # in the future.
- sub _unix_rpt {
- my $unix_rpt;
- if ($use_feature) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- }
- return $unix_rpt;
- }
-
- =item canonpath (override)
-
- Removes redundant portions of file specifications and returns results
- in native syntax unless Unix filename reporting has been enabled.
-
- =cut
-
-
- sub canonpath {
- my($self,$path) = @_;
-
- return undef unless defined $path;
-
- my $unix_rpt = $self->_unix_rpt;
-
- if ($path =~ m|/|) {
- my $pathify = $path =~ m|/\Z(?!\n)|;
- $path = $self->SUPER::canonpath($path);
-
- return $path if $unix_rpt;
- $path = $pathify ? vmspath($path) : vmsify($path);
- }
-
- $path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
- $path =~ s/(?<!\^)>/]/;
- $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
- $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
- $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
- $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
- $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
- 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
- # That loop does the following
- # with any amount of dashes:
- # .-.-. ==> .--.
- # [-.-. ==> [--.
- # .-.-] ==> .--]
- # [-.-] ==> [--]
- 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
- # That loop does the following
- # with any amount (minimum 2)
- # of dashes:
- # .foo.--. ==> .-.
- # .foo.--] ==> .-]
- # [foo.--. ==> [-.
- # [foo.--] ==> [-]
- #
- # And then, the remaining cases
- $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
- $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
- $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
- $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
- # [foo.-] ==> [000000]
- $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
- # [] ==>
- $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
- return $unix_rpt ? unixify($path) : $path;
- }
-
- =item catdir (override)
-
- Concatenates a list of file specifications, and returns the result as a
- native directory specification unless the Unix filename reporting feature
- has been enabled. No check is made for "impossible" cases (e.g. elements
- other than the first being absolute filespecs).
-
- =cut
-
- sub catdir {
- my $self = shift;
- my $dir = pop;
-
- my $unix_rpt = $self->_unix_rpt;
-
- my @dirs = grep {defined() && length()} @_;
-
- my $rslt;
- if (@dirs) {
- my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
- my ($spath,$sdir) = ($path,$dir);
- $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
-
- if ($unix_rpt) {
- $spath = unixify($spath) unless $spath =~ m#/#;
- $sdir= unixify($sdir) unless $sdir =~ m#/#;
- return $self->SUPER::catdir($spath, $sdir)
- }
-
- $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s;
- $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
-
- # Special case for VMS absolute directory specs: these will have
- # had device prepended during trip through Unix syntax in
- # eliminate_macros(), since Unix syntax has no way to express
- # "absolute from the top of this device's directory tree".
- if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; }
-
- } else {
- # Single directory. Return an empty string on null input; otherwise
- # just return a canonical path.
-
- if (not defined $dir or not length $dir) {
- $rslt = '';
- } else {
- $rslt = $unix_rpt ? $dir : vmspath($dir);
- }
- }
- return $self->canonpath($rslt);
- }
-
- =item catfile (override)
-
- Concatenates a list of directory specifications with a filename specification
- to build a path.
-
- =cut
-
- sub catfile {
- my $self = shift;
- my $tfile = pop();
- my $file = $self->canonpath($tfile);
- my @files = grep {defined() && length()} @_;
-
- my $unix_rpt = $self->_unix_rpt;
-
- my $rslt;
- if (@files) {
- my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
- my $spath = $path;
-
- # Something building a VMS path in pieces may try to pass a
- # directory name in filename format, so normalize it.
- $spath =~ s/\.dir\Z(?!\n)//i;
-
- # If the spath ends with a directory delimiter and the file is bare,
- # then just concatenate them.
- if ($spath =~ /^(?<!\^)[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) {
- $rslt = "$spath$file";
- } else {
- $rslt = $self->eliminate_macros($spath);
- $rslt .= (defined($rslt) && length($rslt) ? '/' : '') . unixify($file);
- $rslt = vmsify($rslt) unless $unix_rpt;
- }
- }
- else {
- # Only passed a single file?
- my $xfile = (defined($file) && length($file)) ? $file : '';
-
- $rslt = $unix_rpt ? $file : vmsify($file);
- }
- return $self->canonpath($rslt) unless $unix_rpt;
-
- # In Unix report mode, do not strip off redundant path information.
- return $rslt;
- }
-
-
- =item curdir (override)
-
- Returns a string representation of the current directory: '[]' or '.'
-
- =cut
-
- sub curdir {
- my $self = shift @_;
- return '.' if ($self->_unix_rpt);
- return '[]';
- }
-
- =item devnull (override)
-
- Returns a string representation of the null device: '_NLA0:' or '/dev/null'
-
- =cut
-
- sub devnull {
- my $self = shift @_;
- return '/dev/null' if ($self->_unix_rpt);
- return "_NLA0:";
- }
-
- =item rootdir (override)
-
- Returns a string representation of the root directory: 'SYS$DISK:[000000]'
- or '/'
-
- =cut
-
- sub rootdir {
- my $self = shift @_;
- if ($self->_unix_rpt) {
- # Root may exist, try it first.
- my $try = '/';
- my ($dev1, $ino1) = stat('/');
- my ($dev2, $ino2) = stat('.');
-
- # Perl falls back to '.' if it can not determine '/'
- if (($dev1 != $dev2) || ($ino1 != $ino2)) {
- return $try;
- }
- # Fall back to UNIX format sys$disk.
- return '/sys$disk/';
- }
- return 'SYS$DISK:[000000]';
- }
-
- =item tmpdir (override)
-
- Returns a string representation of the first writable directory
- from the following list or '' if none are writable:
-
- /tmp if C<DECC$FILENAME_UNIX_REPORT> is enabled.
- sys$scratch:
- $ENV{TMPDIR}
-
- If running under taint mode, and if $ENV{TMPDIR}
- is tainted, it is not used.
-
- =cut
-
- sub tmpdir {
- my $self = shift @_;
- my $tmpdir = $self->_cached_tmpdir('TMPDIR');
- return $tmpdir if defined $tmpdir;
- if ($self->_unix_rpt) {
- $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR});
- }
- else {
- $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} );
- }
- $self->_cache_tmpdir($tmpdir, 'TMPDIR');
- }
-
- =item updir (override)
-
- Returns a string representation of the parent directory: '[-]' or '..'
-
- =cut
-
- sub updir {
- my $self = shift @_;
- return '..' if ($self->_unix_rpt);
- return '[-]';
- }
-
- =item case_tolerant (override)
-
- VMS file specification syntax is case-tolerant.
-
- =cut
-
- sub case_tolerant {
- return 1;
- }
-
- =item path (override)
-
- Translate logical name DCL$PATH as a searchlist, rather than trying
- to C<split> string value of C<$ENV{'PATH'}>.
-
- =cut
-
- sub path {
- my (@dirs,$dir,$i);
- while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
- return @dirs;
- }
-
- =item file_name_is_absolute (override)
-
- Checks for VMS directory spec as well as Unix separators.
-
- =cut
-
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- # If it's a logical name, expand it.
- $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file};
- return scalar($file =~ m!^/!s ||
- $file =~ m![<\[][^.\-\]>]! ||
- $file =~ /^[A-Za-z0-9_\$\-\~]+(?<!\^):/);
- }
-
- =item splitpath (override)
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path,
- $no_file );
-
- Passing a true value for C<$no_file> indicates that the path being
- split only contains directory components, even on systems where you
- can usually (when not supporting a foreign syntax) tell the difference
- between directories and files at a glance.
-
- =cut
-
- sub splitpath {
- my($self,$path, $nofile) = @_;
- my($dev,$dir,$file) = ('','','');
- my $vmsify_path = vmsify($path);
-
- if ( $nofile ) {
- #vmsify('d1/d2/d3') returns '[.d1.d2]d3'
- #vmsify('/d1/d2/d3') returns 'd1:[d2]d3'
- if( $vmsify_path =~ /(.*)\](.+)/ ){
- $vmsify_path = $1.'.'.$2.']';
- }
- $vmsify_path =~ /(.+:)?(.*)/s;
- $dir = defined $2 ? $2 : ''; # dir can be '0'
- return ($1 || '',$dir,$file);
- }
- else {
- $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s;
- return ($1 || '',$2 || '',$3);
- }
- }
-
- =item splitdir (override)
-
- Split a directory specification into the components.
-
- =cut
-
- sub splitdir {
- my($self,$dirspec) = @_;
- my @dirs = ();
- return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) );
-
- $dirspec =~ s/(?<!\^)</[/; # < and > ==> [ and ]
- $dirspec =~ s/(?<!\^)>/]/;
- $dirspec =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
- $dirspec =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
- $dirspec =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
- $dirspec =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
- $dirspec =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
- while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {}
- # That loop does the following
- # with any amount of dashes:
- # .--. ==> .-.-.
- # [--. ==> [-.-.
- # .--] ==> .-.-]
- # [--] ==> [-.-]
- $dirspec = "[$dirspec]" unless $dirspec =~ /(?<!\^)[\[<]/; # make legal
- $dirspec =~ s/^(\[|<)\./$1/;
- @dirs = split /(?<!\^)\./, vmspath($dirspec);
- $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s;
- @dirs;
- }
-
-
- =item catpath (override)
-
- Construct a complete filespec.
-
- =cut
-
- sub catpath {
- my($self,$dev,$dir,$file) = @_;
-
- # We look for a volume in $dev, then in $dir, but not both
- my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir);
- $dev = $dir_volume unless length $dev;
- $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir;
-
- if ($dev =~ m|^(?<!\^)/+([^/]+)|) { $dev = "$1:"; }
- else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
- if (length($dev) or length($dir)) {
- $dir = "[$dir]" unless $dir =~ /(?<!\^)[\[<\/]/;
- $dir = vmspath($dir);
- }
- $dir = '' if length($dev) && ($dir eq '[]' || $dir eq '<>');
- "$dev$dir$file";
- }
-
- =item abs2rel (override)
-
- Attempt to convert an absolute file specification to a relative specification.
-
- =cut
-
- sub abs2rel {
- my $self = shift;
- return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
- if grep m{/}, @_;
-
- my($path,$base) = @_;
- $base = $self->_cwd() unless defined $base and length $base;
-
- for ($path, $base) { $_ = $self->canonpath($_) }
-
- # Are we even starting $path on the same (node::)device as $base? Note that
- # logical paths or nodename differences may be on the "same device"
- # but the comparison that ignores device differences so as to concatenate
- # [---] up directory specs is not even a good idea in cases where there is
- # a logical path difference between $path and $base nodename and/or device.
- # Hence we fall back to returning the absolute $path spec
- # if there is a case blind device (or node) difference of any sort
- # and we do not even try to call $parse() or consult %ENV for $trnlnm()
- # (this module needs to run on non VMS platforms after all).
-
- my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
- my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
- return $path unless lc($path_volume) eq lc($base_volume);
-
- for ($path, $base) { $_ = $self->rel2abs($_) }
-
- # Now, remove all leading components that are the same
- my @pathchunks = $self->splitdir( $path_directories );
- my $pathchunks = @pathchunks;
- unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000';
- my @basechunks = $self->splitdir( $base_directories );
- my $basechunks = @basechunks;
- unshift(@basechunks,'000000') unless $basechunks[0] eq '000000';
-
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
- ) {
- shift @pathchunks ;
- shift @basechunks ;
- }
-
- # @basechunks now contains the directories to climb out of,
- # @pathchunks now has the directories to descend in to.
- if ((@basechunks > 0) || ($basechunks != $pathchunks)) {
- $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
- }
- else {
- $path_directories = join '.', @pathchunks;
- }
- $path_directories = '['.$path_directories.']';
- return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
- }
-
-
- =item rel2abs (override)
-
- Return an absolute file specification from a relative one.
-
- =cut
-
- sub rel2abs {
- my $self = shift ;
- my ($path,$base ) = @_;
- return undef unless defined $path;
- if ($path =~ m/\//) {
- $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about
- ? vmspath($path) # whether it's a directory
- : vmsify($path) );
- }
- $base = vmspath($base) if defined $base && $base =~ m/\//;
-
- # Clean up and split up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->_cwd;
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- # Split up paths
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base ) ;
-
- $path_directories = '' if $path_directories eq '[]' ||
- $path_directories eq '<>';
- my $sep = '' ;
- $sep = '.'
- if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} &&
- $path_directories =~ m{^[^.\[<]}s
- ) ;
- $base_directories = "$base_directories$sep$path_directories";
- $base_directories =~ s{\.?[\]>][\[<]\.?}{.};
-
- $path = $self->catpath( $base_volume, $base_directories, $path_file );
- }
-
- return $self->canonpath( $path ) ;
- }
-
-
- # eliminate_macros() and fixpath() are MakeMaker-specific methods
- # which are used inside catfile() and catdir(). MakeMaker has its own
- # copies as of 6.06_03 which are the canonical ones. We leave these
- # here, in peace, so that File::Spec continues to work with MakeMakers
- # prior to 6.06_03.
- #
- # Please consider these two methods deprecated. Do not patch them,
- # patch the ones in ExtUtils::MM_VMS instead.
- #
- # Update: MakeMaker 6.48 is still using these routines on VMS.
- # so they need to be kept up to date with ExtUtils::MM_VMS.
-
- sub eliminate_macros {
- my($self,$path) = @_;
- return '' unless (defined $path) && ($path ne '');
- $self = {} unless ref $self;
-
- if ($path =~ /\s/) {
- return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
- }
-
- my $npath = unixify($path);
- # sometimes unixify will return a string with an off-by-one trailing null
- $npath =~ s{\0$}{};
-
- my($complex) = 0;
- my($head,$macro,$tail);
-
- # perform m##g in scalar context so it acts as an iterator
- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
- if (defined $self->{$2}) {
- ($head,$macro,$tail) = ($1,$2,$3);
- if (ref $self->{$macro}) {
- if (ref $self->{$macro} eq 'ARRAY') {
- $macro = join ' ', @{$self->{$macro}};
- }
- else {
- print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
- "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
- $macro = "\cB$macro\cB";
- $complex = 1;
- }
- }
- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
- $npath = "$head$macro$tail";
- }
- }
- if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
- $npath;
- }
-
- # Deprecated. See the note above for eliminate_macros().
-
- # Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
- # in any directory specification, in order to avoid juxtaposing two
- # VMS-syntax directories when MM[SK] is run. Also expands expressions which
- # are all macro, so that we can tell how long the expansion is, and avoid
- # overrunning DCL's command buffer when MM[KS] is running.
-
- # fixpath() checks to see whether the result matches the name of a
- # directory in the current default directory and returns a directory or
- # file specification accordingly. C<$is_dir> can be set to true to
- # force fixpath() to consider the path to be a directory or false to force
- # it to be a file.
-
- sub fixpath {
- my($self,$path,$force_path) = @_;
- return '' unless $path;
- $self = bless {}, $self unless ref $self;
- my($fixedpath,$prefix,$name);
-
- if ($path =~ /\s/) {
- return join ' ',
- map { $self->fixpath($_,$force_path) }
- split /\s+/, $path;
- }
-
- if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
- if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
- $fixedpath = vmspath($self->eliminate_macros($path));
- }
- else {
- $fixedpath = vmsify($self->eliminate_macros($path));
- }
- }
- elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
- my($vmspre) = $self->eliminate_macros("\$($prefix)");
- # is it a dir or just a name?
- $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
- $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- else {
- $fixedpath = $path;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- # No hints, so we try to guess
- if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
- $fixedpath = vmspath($fixedpath) if -d $fixedpath;
- }
-
- # Trim off root dirname if it's had other dirs inserted in front of it.
- $fixedpath =~ s/\.000000([\]>])/$1/;
- # Special case for VMS absolute directory specs: these will have had device
- # prepended during trip through Unix syntax in eliminate_macros(), since
- # Unix syntax has no way to express "absolute from the top of this device's
- # directory tree".
- if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
- $fixedpath;
- }
-
-
- =back
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =head1 SEE ALSO
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- An explanation of VMS file specs can be found at
- L<http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files>.
-
- =cut
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_VMS
-
-$fatpacked{"File/Spec/Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_WIN32';
- package File::Spec::Win32;
-
- use strict;
-
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
-
- $VERSION = '3.47';
- $VERSION =~ tr/_//;
-
- @ISA = qw(File::Spec::Unix);
-
- # Some regexes we use for path splitting
- my $DRIVE_RX = '[a-zA-Z]:';
- my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
- my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
-
-
- =head1 NAME
-
- File::Spec::Win32 - methods for Win32 file specs
-
- =head1 SYNOPSIS
-
- require File::Spec::Win32; # Done internally by File::Spec if needed
-
- =head1 DESCRIPTION
-
- See File::Spec::Unix for a documentation of the methods provided
- there. This package overrides the implementation of these methods, not
- the semantics.
-
- =over 4
-
- =item devnull
-
- Returns a string representation of the null device.
-
- =cut
-
- sub devnull {
- return "nul";
- }
-
- sub rootdir { '\\' }
-
-
- =item tmpdir
-
- Returns a string representation of the first existing directory
- from the following list:
-
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- SYS:/temp
- C:\system\temp
- C:/temp
- /tmp
- /
-
- The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
- for Symbian (the File::Spec::Win32 is used also for those platforms).
-
- If running under taint mode, and if the environment
- variables are tainted, they are not used.
-
- =cut
-
- sub tmpdir {
- my $tmpdir = $_[0]->_cached_tmpdir(qw(TMPDIR TEMP TMP));
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
- 'SYS:/temp',
- 'C:\system\temp',
- 'C:/temp',
- '/tmp',
- '/' );
- $_[0]->_cache_tmpdir($tmpdir, qw(TMPDIR TEMP TMP));
- }
-
- =item case_tolerant
-
- MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
- indicating the case significance when comparing file specifications.
- Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
- See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
- Default: 1
-
- =cut
-
- sub case_tolerant {
- eval { require Win32API::File; } or return 1;
- my $drive = shift || "C:";
- my $osFsType = "\0"x256;
- my $osVolName = "\0"x256;
- my $ouFsFlags = 0;
- Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
- if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
- else { return 1; }
- }
-
- =item file_name_is_absolute
-
- As of right now, this returns 2 if the path is absolute with a
- volume, 1 if it's absolute with no volume, 0 otherwise.
-
- =cut
-
- sub file_name_is_absolute {
-
- my ($self,$file) = @_;
-
- if ($file =~ m{^($VOL_RX)}o) {
- my $vol = $1;
- return ($vol =~ m{^$UNC_RX}o ? 2
- : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
- : 0);
- }
- return $file =~ m{^[\\/]} ? 1 : 0;
- }
-
- =item catfile
-
- Concatenate one or more directory names and a filename to form a
- complete path ending with a filename
-
- =cut
-
- sub catfile {
- shift;
-
- # Legacy / compatibility support
- #
- shift, return _canon_cat( "/", @_ )
- if $_[0] eq "";
-
- # Compatibility with File::Spec <= 3.26:
- # catfile('A:', 'foo') should return 'A:\foo'.
- return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
- if $_[0] =~ m{^$DRIVE_RX\z}o;
-
- return _canon_cat( @_ );
- }
-
- sub catdir {
- shift;
-
- # Legacy / compatibility support
- #
- return ""
- unless @_;
- shift, return _canon_cat( "/", @_ )
- if $_[0] eq "";
-
- # Compatibility with File::Spec <= 3.26:
- # catdir('A:', 'foo') should return 'A:\foo'.
- return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
- if $_[0] =~ m{^$DRIVE_RX\z}o;
-
- return _canon_cat( @_ );
- }
-
- sub path {
- my @path = split(';', $ENV{PATH});
- s/"//g for @path;
- @path = grep length, @path;
- unshift(@path, ".");
- return @path;
- }
-
- =item canonpath
-
- No physical check on the filesystem, but a logical cleanup of a
- path. On UNIX eliminated successive slashes and successive "/.".
- On Win32 makes
-
- dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
- dir1\dir2\dir3\...\dir4 -> \dir\dir4
-
- =cut
-
- sub canonpath {
- # Legacy / compatibility support
- #
- return $_[1] if !defined($_[1]) or $_[1] eq '';
- return _canon_cat( $_[1] );
- }
-
- =item splitpath
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path,
- $no_file );
-
- Splits a path into volume, directory, and filename portions. Assumes that
- the last file is a path unless the path ends in '\\', '\\.', '\\..'
- or $no_file is true. On Win32 this means that $no_file true makes this return
- ( $volume, $path, '' ).
-
- Separators accepted are \ and /.
-
- Volumes can be drive letters or UNC sharenames (\\server\share).
-
- The results can be passed to L</catpath> to get back a path equivalent to
- (usually identical to) the original path.
-
- =cut
-
- sub splitpath {
- my ($self,$path, $nofile) = @_;
- my ($volume,$directory,$file) = ('','','');
- if ( $nofile ) {
- $path =~
- m{^ ( $VOL_RX ? ) (.*) }sox;
- $volume = $1;
- $directory = $2;
- }
- else {
- $path =~
- m{^ ( $VOL_RX ? )
- ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
- (.*)
- }sox;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
-
- return ($volume,$directory,$file);
- }
-
-
- =item splitdir
-
- The opposite of L<catdir()|File::Spec/catdir>.
-
- @dirs = File::Spec->splitdir( $directories );
-
- $directories must be only the directory portion of the path on systems
- that have the concept of a volume or that have path syntax that differentiates
- files from directories.
-
- Unlike just splitting the directories on the separator, leading empty and
- trailing directory entries can be returned, because these are significant
- on some OSs. So,
-
- File::Spec->splitdir( "/a/b/c" );
-
- Yields:
-
- ( '', 'a', 'b', '', 'c', '' )
-
- =cut
-
- sub splitdir {
- my ($self,$directories) = @_ ;
- #
- # split() likes to forget about trailing null fields, so here we
- # check to be sure that there will not be any before handling the
- # simple case.
- #
- if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
- return split( m|[\\/]|, $directories );
- }
- else {
- #
- # since there was a trailing separator, add a file name to the end,
- # then do the split, then replace it with ''.
- #
- my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
- $directories[ $#directories ]= '' ;
- return @directories ;
- }
- }
-
-
- =item catpath
-
- Takes volume, directory and file portions and returns an entire path. Under
- Unix, $volume is ignored, and this is just like catfile(). On other OSs,
- the $volume become significant.
-
- =cut
-
- sub catpath {
- my ($self,$volume,$directory,$file) = @_;
-
- # If it's UNC, make sure the glue separator is there, reusing
- # whatever separator is first in the $volume
- my $v;
- $volume .= $v
- if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
- $directory =~ m@^[^\\/]@s
- ) ;
-
- $volume .= $directory ;
-
- # If the volume is not just A:, make sure the glue separator is
- # there, reusing whatever separator is first in the $volume if possible.
- if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
- $volume =~ m@[^\\/]\Z(?!\n)@ &&
- $file =~ m@[^\\/]@
- ) {
- $volume =~ m@([\\/])@ ;
- my $sep = $1 ? $1 : '\\' ;
- $volume .= $sep ;
- }
-
- $volume .= $file ;
-
- return $volume ;
- }
-
- sub _same {
- lc($_[1]) eq lc($_[2]);
- }
-
- sub rel2abs {
- my ($self,$path,$base ) = @_;
-
- my $is_abs = $self->file_name_is_absolute($path);
-
- # Check for volume (should probably document the '2' thing...)
- return $self->canonpath( $path ) if $is_abs == 2;
-
- if ($is_abs) {
- # It's missing a volume, add one
- my $vol = ($self->splitpath( $self->_cwd() ))[0];
- return $self->canonpath( $vol . $path );
- }
-
- if ( !defined( $base ) || $base eq '' ) {
- require Cwd ;
- $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
- $base = $self->_cwd() unless defined $base ;
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
-
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path, 1 ))[1,2] ;
-
- my ( $base_volume, $base_directories ) =
- $self->splitpath( $base, 1 ) ;
-
- $path = $self->catpath(
- $base_volume,
- $self->catdir( $base_directories, $path_directories ),
- $path_file
- ) ;
-
- return $self->canonpath( $path ) ;
- }
-
- =back
-
- =head2 Note For File::Spec::Win32 Maintainers
-
- Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
-
- =head1 COPYRIGHT
-
- Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =head1 SEE ALSO
-
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
-
- =cut
-
-
- sub _canon_cat # @path -> path
- {
- my ($first, @rest) = @_;
-
- my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
- ? ucfirst( $1 ).( $2 ? "\\" : "" )
- : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
- (?: [\\/] ([^\\/]+) )?
- [\\/]? }{}xs # UNC volume
- ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
- : $first =~ s{ \A [\\/] }{}x # root dir
- ? "\\"
- : "";
- my $path = join "\\", $first, @rest;
-
- $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
-
- # xx/././yy --> xx/yy
- $path =~ s{(?:
- (?:\A|\\) # at begin or after a slash
- \.
- (?:\\\.)* # and more
- (?:\\|\z) # at end or followed by slash
- )+ # performance boost -- I do not know why
- }{\\}gx;
-
- # XXX I do not know whether more dots are supported by the OS supporting
- # this ... annotation (NetWare or symbian but not MSWin32).
- # Then .... could easily become ../../.. etc:
- # Replace \.\.\. by (\.\.\.+) and substitute with
- # { $1 . ".." . "\\.." x (length($2)-2) }gex
- # ... --> ../..
- $path =~ s{ (\A|\\) # at begin or after a slash
- \.\.\.
- (?=\\|\z) # at end or followed by slash
- }{$1..\\..}gx;
- # xx\yy\..\zz --> xx\zz
- while ( $path =~ s{(?:
- (?:\A|\\) # at begin or after a slash
- [^\\]+ # rip this 'yy' off
- \\\.\.
- (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
- (?<!\\\.\.\\\.\.) # do *not* replace \..\..
- (?:\\|\z) # at end or followed by slash
- )+ # performance boost -- I do not know why
- }{\\}sx ) {}
-
- $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
- $path =~ s#\\\z##; # xx\ --> xx
-
- if ( $volume =~ m#\\\z# )
- { # <vol>\.. --> <vol>\
- $path =~ s{ \A # at begin
- \.\.
- (?:\\\.\.)* # and more
- (?:\\|\z) # at end or followed by slash
- }{}x;
-
- return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
- if $path eq ""
- and $volume =~ m#\A(\\\\.*)\\\z#s;
- }
- return $path ne "" || $volume ? $volume.$path : ".";
- }
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_FILE_SPEC_WIN32
-
$fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS';
=head1 NAME
@@ -77418,7 +74706,7 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
use common::sense;
- our $VERSION = 3.01;
+ our $VERSION = 3.03;
our @ISA = qw(Exporter);
our @EXPORT = qw(encode_json decode_json);
@@ -77721,6 +75009,16 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
# neither this one...
]
+ =item * literal ASCII TAB characters in strings
+
+ Literal ASCII TAB characters are now allowed in strings (and treated as
+ C<\t>).
+
+ [
+ "Hello\tWorld",
+ "Hello<TAB>World", # literal <TAB> would not normally be allowed
+ ]
+
=back
=item $json = $json->canonical ([$enable])
@@ -78004,7 +75302,7 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
and you need to know where the JSON text ends.
JSON::XS->new->decode_prefix ("[1] the tail")
- => ([], 3)
+ => ([1], 3)
=back
@@ -78055,11 +75353,11 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
- otherwise. For this to work, there must be no separators between the JSON
- objects or arrays, instead they must be concatenated back-to-back. If
- an error occurs, an exception will be raised as in the scalar context
- case. Note that in this case, any previously-parsed JSON texts will be
- lost.
+ otherwise. For this to work, there must be no separators (other than
+ whitespace) between the JSON objects or arrays, instead they must be
+ concatenated back-to-back. If an error occurs, an exception will be
+ raised as in the scalar context case. Note that in this case, any
+ previously-parsed JSON texts will be lost.
Example: Parse some JSON arrays/objects in a given string and return
them.
@@ -78076,6 +75374,10 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
real world conditions). As a special exception, you can also call this
method before having parsed anything.
+ That means you can only use this function to look at or manipulate text
+ before or after complete JSON objects, not while the parser is in the
+ middle of parsing a JSON object.
+
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
@@ -78870,14 +76172,135 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).'
security right).
+ =head1 "OLD" VS. "NEW" JSON (RFC 4627 VS. RFC 7159)
+
+ TL;DR: Due to security concerns, JSON::XS will not allow scalar data in
+ JSON texts by default - you need to create your own JSON::XS object and
+ enable C<allow_nonref>:
+
+
+ my $json = JSON::XS->new->allow_nonref;
+
+ $text = $json->encode ($data);
+ $data = $json->decode ($text);
+
+ The long version: JSON being an important and supposedly stable format,
+ the IETF standardised it as RFC 4627 in 2006. Unfortunately, the inventor
+ of JSON, Dougles Crockford, unilaterally changed the definition of JSON in
+ javascript. Rather than create a fork, the IETF decided to standardise the
+ new syntax (apparently, so Iw as told, without finding it very amusing).
+
+ The biggest difference between thed original JSON and the new JSON is that
+ the new JSON supports scalars (anything other than arrays and objects) at
+ the toplevel of a JSON text. While this is strictly backwards compatible
+ to older versions, it breaks a number of protocols that relied on sending
+ JSON back-to-back, and is a minor security concern.
+
+ For example, imagine you have two banks communicating, and on one side,
+ trhe JSON coder gets upgraded. Two messages, such as C<10> and C<1000>
+ might then be confused to mean C<101000>, something that couldn't happen
+ in the original JSON, because niether of these messages would be valid
+ JSON.
+
+ If one side accepts these messages, then an upgrade in the coder on either
+ side could result in this becoming exploitable.
+
+ This module has always allowed these messages as an optional extension, by
+ default disabled. The security concerns are the reason why the default is
+ still disabled, but future versions might/will likely upgrade to the newer
+ RFC as default format, so you are advised to check your implementation
+ and/or override the default with C<< ->allow_nonref (0) >> to ensure that
+ future versions are safe.
+
+
=head1 INTEROPERABILITY WITH OTHER MODULES
C<JSON::XS> uses the L<Types::Serialiser> module to provide boolean
constants. That means that the JSON true and false values will be
- comaptible to true and false values of iother modules that do the same,
+ comaptible to true and false values of other modules that do the same,
such as L<JSON::PP> and L<CBOR::XS>.
+ =head1 INTEROPERABILITY WITH OTHER JSON DECODERS
+
+ As long as you only serialise data that can be directly expressed in JSON,
+ C<JSON::XS> is incapable of generating invalid JSON output (modulo bugs,
+ but C<JSON::XS> has found more bugs in the official JSON testsuite (1)
+ than the official JSON testsuite has found in C<JSON::XS> (0)).
+
+ When you have trouble decoding JSON generated by this module using other
+ decoders, then it is very likely that you have an encoding mismatch or the
+ other decoder is broken.
+
+ When decoding, C<JSON::XS> is strict by default and will likely catch all
+ errors. There are currently two settings that change this: C<relaxed>
+ makes C<JSON::XS> accept (but not generate) some non-standard extensions,
+ and C<allow_tags> will allow you to encode and decode Perl objects, at the
+ cost of not outputting valid JSON anymore.
+
+ =head2 TAGGED VALUE SYNTAX AND STANDARD JSON EN/DECODERS
+
+ When you use C<allow_tags> to use the extended (and also nonstandard and
+ invalid) JSON syntax for serialised objects, and you still want to decode
+ the generated When you want to serialise objects, you can run a regex
+ to replace the tagged syntax by standard JSON arrays (it only works for
+ "normal" package names without comma, newlines or single colons). First,
+ the readable Perl version:
+
+ # if your FREEZE methods return no values, you need this replace first:
+ $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[\s*\]/[$1]/gx;
+
+ # this works for non-empty constructor arg lists:
+ $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[/[$1,/gx;
+
+ And here is a less readable version that is easy to adapt to other
+ languages:
+
+ $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/[$1,/g;
+
+ Here is an ECMAScript version (same regex):
+
+ json = json.replace (/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/g, "[$1,");
+
+ Since this syntax converts to standard JSON arrays, it might be hard to
+ distinguish serialised objects from normal arrays. You can prepend a
+ "magic number" as first array element to reduce chances of a collision:
+
+ $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/["XU1peReLzT4ggEllLanBYq4G9VzliwKF",$1,/g;
+
+ And after decoding the JSON text, you could walk the data
+ structure looking for arrays with a first element of
+ C<XU1peReLzT4ggEllLanBYq4G9VzliwKF>.
+
+ The same approach can be used to create the tagged format with another
+ encoder. First, you create an array with the magic string as first member,
+ the classname as second, and constructor arguments last, encode it as part
+ of your JSON structure, and then:
+
+ $json =~ s/\[\s*"XU1peReLzT4ggEllLanBYq4G9VzliwKF"\s*,\s*("([^\\":,]+|\\.|::)*")\s*,/($1)[/g;
+
+ Again, this has some limitations - the magic string must not be encoded
+ with character escapes, and the constructor arguments must be non-empty.
+
+
+ =head1 RFC7159
+
+ Since this module was written, Google has written a new JSON RFC, RFC 7159
+ (and RFC7158). Unfortunately, this RFC breaks compatibility with both the
+ original JSON specification on www.json.org and RFC4627.
+
+ As far as I can see, you can get partial compatibility when parsing by
+ using C<< ->allow_nonref >>. However, consider the security implications
+ of doing so.
+
+ I haven't decided yet when to break compatibility with RFC4627 by default
+ (and potentially leave applications insecure) and change the default to
+ follow RFC7159, but application authors are well advised to call C<<
+ ->allow_nonref(0) >> even if this is the current default, if they cannot
+ handle non-reference values, in preparation for the day when the default
+ will change.
+
+
=head1 THREADS
This module is I<not> guaranteed to be thread safe and there are no
@@ -78978,185 +76401,6 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS/Boolean.pm"} = '#line '.(1+__L
X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS_BOOLEAN
-$fatpacked{"x86_64-linux-gnu-thread-multi/Sub/Name.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_SUB_NAME';
- package Sub::Name; # git description: v0.13-7-g79187d2
- # ABSTRACT: (re)name a sub
-
- #pod =pod
- #pod
- #pod =head1 SYNOPSIS
- #pod
- #pod use Sub::Name;
- #pod
- #pod subname $name, $subref;
- #pod
- #pod $subref = subname foo => sub { ... };
- #pod
- #pod =head1 DESCRIPTION
- #pod
- #pod This module has only one function, which is also exported by default:
- #pod
- #pod =for stopwords subname
- #pod
- #pod =head2 subname NAME, CODEREF
- #pod
- #pod Assigns a new name to referenced sub. If package specification is omitted in
- #pod the name, then the current package is used. The return value is the sub.
- #pod
- #pod The name is only used for informative routines (caller, Carp, etc). You won't
- #pod be able to actually invoke the sub by the given name. To allow that, you need
- #pod to do glob-assignment yourself.
- #pod
- #pod Note that for anonymous closures (subs that reference lexicals declared outside
- #pod the sub itself) you can name each instance of the closure differently, which
- #pod can be very useful for debugging.
- #pod
- #pod =head1 SEE ALSO
- #pod
- #pod =for :list
- #pod * L<Sub::Identify> - for getting information about subs
- #pod * L<Sub::Util> - set_subname is another implementation of C<subname>
- #pod
- #pod =for stopwords cPanel
- #pod
- #pod =head1 COPYRIGHT AND LICENSE
- #pod
- #pod This software is copyright (c) 2004, 2008 by Matthijs van Duin, all rights reserved;
- #pod copyright (c) 2014 cPanel Inc., all rights reserved.
- #pod
- #pod This program is free software; you can redistribute it and/or modify
- #pod it under the same terms as Perl itself.
- #pod
- #pod =cut
-
- use 5.006;
-
- use strict;
- use warnings;
-
- our $VERSION = '0.14';
-
- use Exporter 5.57 'import';
-
- our @EXPORT = qw(subname);
- our @EXPORT_OK = @EXPORT;
-
- use XSLoader;
- XSLoader::load(
- __PACKAGE__,
- $VERSION,
- );
-
- 1;
-
- __END__
-
- =pod
-
- =encoding UTF-8
-
- =head1 NAME
-
- Sub::Name - (re)name a sub
-
- =head1 VERSION
-
- version 0.14
-
- =head1 SYNOPSIS
-
- use Sub::Name;
-
- subname $name, $subref;
-
- $subref = subname foo => sub { ... };
-
- =head1 DESCRIPTION
-
- This module has only one function, which is also exported by default:
-
- =for stopwords subname
-
- =head2 subname NAME, CODEREF
-
- Assigns a new name to referenced sub. If package specification is omitted in
- the name, then the current package is used. The return value is the sub.
-
- The name is only used for informative routines (caller, Carp, etc). You won't
- be able to actually invoke the sub by the given name. To allow that, you need
- to do glob-assignment yourself.
-
- Note that for anonymous closures (subs that reference lexicals declared outside
- the sub itself) you can name each instance of the closure differently, which
- can be very useful for debugging.
-
- =head1 SEE ALSO
-
- =over 4
-
- =item *
-
- L<Sub::Identify> - for getting information about subs
-
- =item *
-
- L<Sub::Util> - set_subname is another implementation of C<subname>
-
- =back
-
- =for stopwords cPanel
-
- =head1 AUTHOR
-
- Matthijs van Duin <xmath@cpan.org>
-
- =head1 CONTRIBUTORS
-
- =for stopwords Karen Etheridge Florian Ragwitz Matthijs van Duin Reini Urban Dagfinn Ilmari Mannsåker gfx J.R. Mash
-
- =over 4
-
- =item *
-
- Karen Etheridge <ether@cpan.org>
-
- =item *
-
- Florian Ragwitz <rafl@debian.org>
-
- =item *
-
- Matthijs van Duin <xmath-no-spam@nospam.cpan.org>
-
- =item *
-
- Reini Urban <rurban@cpanel.net>
-
- =item *
-
- Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
-
- =item *
-
- gfx <gfuji@cpan.org>
-
- =item *
-
- J.R. Mash <jmash.code@gmail.com>
-
- =back
-
- =head1 COPYRIGHT AND LICENSE
-
- This software is copyright (c) 2004, 2008 by Matthijs van Duin, all rights reserved;
- copyright (c) 2014 cPanel Inc., all rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
-
- =cut
-X86_64-LINUX-GNU-THREAD-MULTI_SUB_NAME
-
$fatpacked{"x86_64-linux-gnu-thread-multi/common/sense.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_COMMON_SENSE';
package common::sense;
@@ -79167,1332 +76411,15 @@ $fatpacked{"x86_64-linux-gnu-thread-multi/common/sense.pm"} = '#line '.(1+__LINE
sub import {
local $^W; # work around perl 5.16 spewing out warnings for next statement
# use warnings
- ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\x0c\x3f\x33\x00\x0f\xf0\x0f\xc0\xf0\xfc\x33\x00";
+ ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\x0c\x3f\x33\x00\x0f\xf0\x0f\xc0\xf0\xfc\x33\x00\x00";
# use strict, use utf8; use feature;
- $^H |= 0x820700;
- @^H{qw(feature_say feature_state feature_switch)} = (1) x 3;
+ $^H |= 0x820f00;
+ @^H{qw(feature_unicode feature_say feature_state feature_switch)} = (1) x 4;
}
1
X86_64-LINUX-GNU-THREAD-MULTI_COMMON_SENSE
-$fatpacked{"x86_64-linux-gnu-thread-multi/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION';
- #!perl -w
- package version;
-
- use 5.006002;
- use strict;
- use warnings::register;
- if ($] >= 5.015) {
- warnings::register_categories(qw/version/);
- }
-
- use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-
- $VERSION = 0.9912;
- $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
- eval "use version::vpp $VERSION"; # don't tempt fate
- die "$@" if ( $@ );
- push @ISA, "version::vpp";
- local $^W;
- *version::qv = \&version::vpp::qv;
- *version::declare = \&version::vpp::declare;
- *version::_VERSION = \&version::vpp::_VERSION;
- *version::vcmp = \&version::vpp::vcmp;
- *version::new = \&version::vpp::new;
- *version::numify = \&version::vpp::numify;
- *version::normal = \&version::vpp::normal;
- if ($] >= 5.009000) {
- no strict 'refs';
- *version::stringify = \&version::vpp::stringify;
- *{'version::(""'} = \&version::vpp::stringify;
- *{'version::(<=>'} = \&version::vpp::vcmp;
- *version::parse = \&version::vpp::parse;
- }
- }
- else { # use XS module
- push @ISA, "version::vxs";
- local $^W;
- *version::declare = \&version::vxs::declare;
- *version::qv = \&version::vxs::qv;
- *version::_VERSION = \&version::vxs::_VERSION;
- *version::vcmp = \&version::vxs::VCMP;
- *version::new = \&version::vxs::new;
- *version::numify = \&version::vxs::numify;
- *version::normal = \&version::vxs::normal;
- if ($] >= 5.009000) {
- no strict 'refs';
- *version::stringify = \&version::vxs::stringify;
- *{'version::(""'} = \&version::vxs::stringify;
- *{'version::(<=>'} = \&version::vxs::VCMP;
- *version::parse = \&version::vxs::parse;
- }
- }
- }
-
- # avoid using Exporter
- 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;
-
- # Set up any derived class
- unless ($class eq $CLASS) {
- local $^W;
- *{$class.'::declare'} = \&{$CLASS.'::declare'};
- *{$class.'::qv'} = \&{$CLASS.'::qv'};
- }
-
- my %args;
- if (@_) { # any remaining terms are arguments
- map { $args{$_} = 1 } @_
- }
- else { # no parameters at all on use line
- %args =
- (
- qv => 1,
- 'UNIVERSAL::VERSION' => 1,
- );
- }
-
- my $callpkg = caller();
-
- if (exists($args{declare})) {
- *{$callpkg.'::declare'} =
- sub {return $class->declare(shift) }
- unless defined(&{$callpkg.'::declare'});
- }
-
- if (exists($args{qv})) {
- *{$callpkg.'::qv'} =
- sub {return $class->qv(shift) }
- unless defined(&{$callpkg.'::qv'});
- }
-
- if (exists($args{'UNIVERSAL::VERSION'})) {
- local $^W;
- *UNIVERSAL::VERSION
- = \&{$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;
-X86_64-LINUX-GNU-THREAD-MULTI_VERSION
-
-$fatpacked{"x86_64-linux-gnu-thread-multi/version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION_REGEX';
- package version::regex;
-
- use strict;
-
- use vars qw($VERSION $CLASS $STRICT $LAX);
-
- $VERSION = 0.9912;
-
- #--------------------------------------------------------------------------#
- # Version regexp components
- #--------------------------------------------------------------------------#
-
- # Fraction part of a decimal version number. This is a common part of
- # both strict and lax decimal versions
-
- my $FRACTION_PART = qr/\.[0-9]+/;
-
- # First part of either decimal or dotted-decimal strict version number.
- # Unsigned integer with no leading zeroes (except for zero itself) to
- # avoid confusion with octal.
-
- my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
-
- # First part of either decimal or dotted-decimal lax version number.
- # Unsigned integer, but allowing leading zeros. Always interpreted
- # as decimal. However, some forms of the resulting syntax give odd
- # results if used as ordinary Perl expressions, due to how perl treats
- # octals. E.g.
- # version->new("010" ) == 10
- # version->new( 010 ) == 8
- # version->new( 010.2) == 82 # "8" . "2"
-
- my $LAX_INTEGER_PART = qr/[0-9]+/;
-
- # Second and subsequent part of a strict dotted-decimal version number.
- # Leading zeroes are permitted, and the number is always decimal.
- # Limited to three digits to avoid overflow when converting to decimal
- # form and also avoid problematic style with excessive leading zeroes.
-
- my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
-
- # Second and subsequent part of a lax dotted-decimal version number.
- # Leading zeroes are permitted, and the number is always decimal. No
- # limit on the numerical value or number of digits, so there is the
- # possibility of overflow when converting to decimal form.
-
- my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
-
- # Alpha suffix part of lax version number syntax. Acts like a
- # dotted-decimal part.
-
- my $LAX_ALPHA_PART = qr/_[0-9]+/;
-
- #--------------------------------------------------------------------------#
- # Strict version regexp definitions
- #--------------------------------------------------------------------------#
-
- # Strict decimal version number.
-
- my $STRICT_DECIMAL_VERSION =
- qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
-
- # Strict dotted-decimal version number. Must have both leading "v" and
- # at least three parts, to avoid confusion with decimal syntax.
-
- my $STRICT_DOTTED_DECIMAL_VERSION =
- qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
-
- # Complete strict version number syntax -- should generally be used
- # anchored: qr/ \A $STRICT \z /x
-
- $STRICT =
- qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
-
- #--------------------------------------------------------------------------#
- # Lax version regexp definitions
- #--------------------------------------------------------------------------#
-
- # Lax decimal version number. Just like the strict one except for
- # allowing an alpha suffix or allowing a leading or trailing
- # decimal-point
-
- my $LAX_DECIMAL_VERSION =
- qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
- |
- $FRACTION_PART $LAX_ALPHA_PART?
- /x;
-
- # Lax dotted-decimal version number. Distinguished by having either
- # leading "v" or at least three non-alpha parts. Alpha part is only
- # permitted if there are at least two non-alpha parts. Strangely
- # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
- # so when there is no "v", the leading part is optional
-
- my $LAX_DOTTED_DECIMAL_VERSION =
- qr/
- v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
- |
- $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
- /x;
-
- # Complete lax version number syntax -- should generally be used
- # anchored: qr/ \A $LAX \z /x
- #
- # The string 'undef' is a special case to make for easier handling
- # of return values from ExtUtils::MM->parse_version
-
- $LAX =
- qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
-
- #--------------------------------------------------------------------------#
-
- # Preloaded methods go here.
- sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
- sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_VERSION_REGEX
-
-$fatpacked{"x86_64-linux-gnu-thread-multi/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VPP';
- package charstar;
- # a little helper class to emulate C char* semantics in Perl
- # so that prescan_version can use the same code as in C
-
- use overload (
- '""' => \&thischar,
- '0+' => \&thischar,
- '++' => \&increment,
- '--' => \&decrement,
- '+' => \&plus,
- '-' => \&minus,
- '*' => \&multiply,
- 'cmp' => \&cmp,
- '<=>' => \&spaceship,
- 'bool' => \&thischar,
- '=' => \&clone,
- );
-
- sub new {
- my ($self, $string) = @_;
- my $class = ref($self) || $self;
-
- my $obj = {
- string => [split(//,$string)],
- current => 0,
- };
- return bless $obj, $class;
- }
-
- sub thischar {
- my ($self) = @_;
- my $last = $#{$self->{string}};
- my $curr = $self->{current};
- if ($curr >= 0 && $curr <= $last) {
- return $self->{string}->[$curr];
- }
- else {
- return '';
- }
- }
-
- sub increment {
- my ($self) = @_;
- $self->{current}++;
- }
-
- sub decrement {
- my ($self) = @_;
- $self->{current}--;
- }
-
- sub plus {
- my ($self, $offset) = @_;
- my $rself = $self->clone;
- $rself->{current} += $offset;
- return $rself;
- }
-
- sub minus {
- my ($self, $offset) = @_;
- my $rself = $self->clone;
- $rself->{current} -= $offset;
- return $rself;
- }
-
- sub multiply {
- my ($left, $right, $swapped) = @_;
- my $char = $left->thischar();
- return $char * $right;
- }
-
- sub spaceship {
- my ($left, $right, $swapped) = @_;
- unless (ref($right)) { # not an object already
- $right = $left->new($right);
- }
- return $left->{current} <=> $right->{current};
- }
-
- sub cmp {
- my ($left, $right, $swapped) = @_;
- unless (ref($right)) { # not an object already
- if (length($right) == 1) { # comparing single character only
- return $left->thischar cmp $right;
- }
- $right = $left->new($right);
- }
- return $left->currstr cmp $right->currstr;
- }
-
- sub bool {
- my ($self) = @_;
- my $char = $self->thischar;
- return ($char ne '');
- }
-
- sub clone {
- my ($left, $right, $swapped) = @_;
- $right = {
- string => [@{$left->{string}}],
- current => $left->{current},
- };
- return bless $right, ref($left);
- }
-
- sub currstr {
- my ($self, $s) = @_;
- my $curr = $self->{current};
- my $last = $#{$self->{string}};
- if (defined($s) && $s->{current} < $last) {
- $last = $s->{current};
- }
-
- my $string = join('', @{$self->{string}}[$curr..$last]);
- return $string;
- }
-
- package version::vpp;
-
- use 5.006002;
- use strict;
- use warnings::register;
-
- use Config;
- use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);
- $VERSION = 0.9912;
- $CLASS = 'version::vpp';
- if ($] > 5.015) {
- warnings::register_categories(qw/version/);
- $WARN_CATEGORY = 'version';
- } else {
- $WARN_CATEGORY = 'numeric';
- }
-
- 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,
- );
-
- sub import {
- no strict 'refs';
- my ($class) = shift;
-
- # Set up any derived class
- unless ($class eq $CLASS) {
- local $^W;
- *{$class.'::declare'} = \&{$CLASS.'::declare'};
- *{$class.'::qv'} = \&{$CLASS.'::qv'};
- }
-
- my %args;
- if (@_) { # any remaining terms are arguments
- map { $args{$_} = 1 } @_
- }
- else { # no parameters at all on use line
- %args =
- (
- qv => 1,
- 'UNIVERSAL::VERSION' => 1,
- );
- }
-
- my $callpkg = caller();
-
- if (exists($args{declare})) {
- *{$callpkg.'::declare'} =
- sub {return $class->declare(shift) }
- unless defined(&{$callpkg.'::declare'});
- }
-
- if (exists($args{qv})) {
- *{$callpkg.'::qv'} =
- sub {return $class->qv(shift) }
- unless defined(&{$callpkg.'::qv'});
- }
-
- if (exists($args{'UNIVERSAL::VERSION'})) {
- no warnings qw/redefine/;
- *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'});
- }
- }
-
- my $VERSION_MAX = 0x7FFFFFFF;
-
- # implement prescan_version as closely to the C version as possible
- use constant TRUE => 1;
- use constant FALSE => 0;
-
- sub isDIGIT {
- my ($char) = shift->thischar();
- return ($char =~ /\d/);
- }
-
- sub isALPHA {
- my ($char) = shift->thischar();
- return ($char =~ /[a-zA-Z]/);
- }
-
- sub isSPACE {
- my ($char) = shift->thischar();
- return ($char =~ /\s/);
- }
-
- sub BADVERSION {
- my ($s, $errstr, $error) = @_;
- if ($errstr) {
- $$errstr = $error;
- }
- return $s;
- }
-
- sub prescan_version {
- my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
- my $qv = defined $sqv ? $$sqv : FALSE;
- my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
- my $width = defined $swidth ? $$swidth : 3;
- my $alpha = defined $salpha ? $$salpha : FALSE;
-
- my $d = $s;
-
- if ($qv && isDIGIT($d)) {
- goto dotted_decimal_version;
- }
-
- if ($d eq 'v') { # explicit v-string
- $d++;
- if (isDIGIT($d)) {
- $qv = TRUE;
- }
- else { # degenerate v-string
- # requires v1.2.3
- return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
-
- dotted_decimal_version:
- if ($strict && $d eq '0' && isDIGIT($d+1)) {
- # no leading zeros allowed
- return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
- }
-
- while (isDIGIT($d)) { # integer part
- $d++;
- }
-
- if ($d eq '.')
- {
- $saw_decimal++;
- $d++; # decimal point
- }
- else
- {
- if ($strict) {
- # require v1.2.3
- return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- else {
- goto version_prescan_finish;
- }
- }
-
- {
- my $i = 0;
- my $j = 0;
- while (isDIGIT($d)) { # just keep reading
- $i++;
- while (isDIGIT($d)) {
- $d++; $j++;
- # maximum 3 digits between decimal
- if ($strict && $j > 3) {
- return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
- }
- }
- if ($d eq '_') {
- if ($strict) {
- return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
- }
- if ( $alpha ) {
- return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
- }
- $d++;
- $alpha = TRUE;
- }
- elsif ($d eq '.') {
- if ($alpha) {
- return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
- }
- $saw_decimal++;
- $d++;
- }
- elsif (!isDIGIT($d)) {
- last;
- }
- $j = 0;
- }
-
- if ($strict && $i < 2) {
- # requires v1.2.3
- return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- }
- } # end if dotted-decimal
- else
- { # decimal versions
- my $j = 0;
- # special $strict case for leading '.' or '0'
- if ($strict) {
- if ($d eq '.') {
- return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
- }
- if ($d eq '0' && isDIGIT($d+1)) {
- return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
- }
- }
-
- # and we never support negative version numbers
- if ($d eq '-') {
- return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
- }
-
- # consume all of the integer part
- while (isDIGIT($d)) {
- $d++;
- }
-
- # look for a fractional part
- if ($d eq '.') {
- # we found it, so consume it
- $saw_decimal++;
- $d++;
- }
- elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
- if ( $d == $s ) {
- # found nothing
- return BADVERSION($s,$errstr,"Invalid version format (version required)");
- }
- # found just an integer
- goto version_prescan_finish;
- }
- elsif ( $d == $s ) {
- # didn't find either integer or period
- return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
- }
- elsif ($d eq '_') {
- # underscore can't come after integer part
- if ($strict) {
- return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
- }
- elsif (isDIGIT($d+1)) {
- return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
- }
- else {
- return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
- }
- }
- elsif ($d) {
- # anything else after integer part is just invalid data
- return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
- }
-
- # scan the fractional part after the decimal point
- if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
- # $strict or lax-but-not-the-end
- return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
- }
-
- while (isDIGIT($d)) {
- $d++; $j++;
- if ($d eq '.' && isDIGIT($d-1)) {
- if ($alpha) {
- return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
- }
- if ($strict) {
- return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
- }
- $d = $s; # start all over again
- $qv = TRUE;
- goto dotted_decimal_version;
- }
- if ($d eq '_') {
- if ($strict) {
- return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
- }
- if ( $alpha ) {
- return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
- }
- if ( ! isDIGIT($d+1) ) {
- return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
- }
- $width = $j;
- $d++;
- $alpha = TRUE;
- }
- }
- }
-
- version_prescan_finish:
- while (isSPACE($d)) {
- $d++;
- }
-
- if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
- # trailing non-numeric data
- return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
- }
- if ($saw_decimal > 1 && ($d-1) eq '.') {
- # no trailing period allowed
- return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)");
- }
-
- if (defined $sqv) {
- $$sqv = $qv;
- }
- if (defined $swidth) {
- $$swidth = $width;
- }
- if (defined $ssaw_decimal) {
- $$ssaw_decimal = $saw_decimal;
- }
- if (defined $salpha) {
- $$salpha = $alpha;
- }
- return $d;
- }
-
- sub scan_version {
- my ($s, $rv, $qv) = @_;
- my $start;
- my $pos;
- my $last;
- my $errstr;
- my $saw_decimal = 0;
- my $width = 3;
- my $alpha = FALSE;
- my $vinf = FALSE;
- my @av;
-
- $s = new charstar $s;
-
- while (isSPACE($s)) { # leading whitespace is OK
- $s++;
- }
-
- $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
- \$width, \$alpha);
-
- if ($errstr) {
- # 'undef' is a special case and not an error
- if ( $s ne 'undef') {
- require Carp;
- Carp::croak($errstr);
- }
- }
-
- $start = $s;
- if ($s eq 'v') {
- $s++;
- }
- $pos = $s;
-
- if ( $qv ) {
- $$rv->{qv} = $qv;
- }
- if ( $alpha ) {
- $$rv->{alpha} = $alpha;
- }
- if ( !$qv && $width < 3 ) {
- $$rv->{width} = $width;
- }
-
- while (isDIGIT($pos)) {
- $pos++;
- }
- if (!isALPHA($pos)) {
- my $rev;
-
- for (;;) {
- $rev = 0;
- {
- # this is atoi() that delimits on underscores
- my $end = $pos;
- my $mult = 1;
- my $orev;
-
- # the following if() will only be true after the decimal
- # point of a version originally created with a bare
- # floating point number, i.e. not quoted in any way
- #
- if ( !$qv && $s > $start && $saw_decimal == 1 ) {
- $mult *= 100;
- while ( $s < $end ) {
- $orev = $rev;
- $rev += $s * $mult;
- $mult /= 10;
- if ( (abs($orev) > abs($rev))
- || (abs($rev) > $VERSION_MAX )) {
- warn("Integer overflow in version %d",
- $VERSION_MAX);
- $s = $end - 1;
- $rev = $VERSION_MAX;
- $vinf = 1;
- }
- $s++;
- if ( $s eq '_' ) {
- $s++;
- }
- }
- }
- else {
- while (--$end >= $s) {
- $orev = $rev;
- $rev += $end * $mult;
- $mult *= 10;
- if ( (abs($orev) > abs($rev))
- || (abs($rev) > $VERSION_MAX )) {
- warn("Integer overflow in version");
- $end = $s - 1;
- $rev = $VERSION_MAX;
- $vinf = 1;
- }
- }
- }
- }
-
- # Append revision
- push @av, $rev;
- if ( $vinf ) {
- $s = $last;
- last;
- }
- elsif ( $pos eq '.' ) {
- $pos++;
- if ($qv) {
- # skip leading zeros
- while ($pos eq '0') {
- $pos++;
- }
- }
- $s = $pos;
- }
- elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
- $s = ++$pos;
- }
- elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
- $s = ++$pos;
- }
- elsif ( isDIGIT($pos) ) {
- $s = $pos;
- }
- else {
- $s = $pos;
- last;
- }
- if ( $qv ) {
- while ( isDIGIT($pos) ) {
- $pos++;
- }
- }
- else {
- my $digits = 0;
- while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
- if ( $pos ne '_' ) {
- $digits++;
- }
- $pos++;
- }
- }
- }
- }
- if ( $qv ) { # quoted versions always get at least three terms
- my $len = $#av;
- # This for loop appears to trigger a compiler bug on OS X, as it
- # loops infinitely. Yes, len is negative. No, it makes no sense.
- # Compiler in question is:
- # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
- # for ( len = 2 - len; len > 0; len-- )
- # av_push(MUTABLE_AV(sv), newSViv(0));
- #
- $len = 2 - $len;
- while ($len-- > 0) {
- push @av, 0;
- }
- }
-
- # need to save off the current version string for later
- if ( $vinf ) {
- $$rv->{original} = "v.Inf";
- $$rv->{vinf} = 1;
- }
- elsif ( $s > $start ) {
- $$rv->{original} = $start->currstr($s);
- if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
- # need to insert a v to be consistent
- $$rv->{original} = 'v' . $$rv->{original};
- }
- }
- else {
- $$rv->{original} = '0';
- push(@av, 0);
- }
-
- # And finally, store the AV in the hash
- $$rv->{version} = \@av;
-
- # fix RT#19517 - special case 'undef' as string
- if ($s eq 'undef') {
- $s += 5;
- }
-
- return $s;
- }
-
- sub new {
- my $class = shift;
- unless (defined $class or $#_ > 1) {
- require Carp;
- Carp::croak('Usage: version::new(class, version)');
- }
-
- my $self = bless ({}, ref ($class) || $class);
- my $qv = FALSE;
-
- if ( $#_ == 1 ) { # must be CVS-style
- $qv = TRUE;
- }
- my $value = pop; # always going to be the last element
-
- if ( ref($value) && eval('$value->isa("version")') ) {
- # Can copy the elements directly
- $self->{version} = [ @{$value->{version} } ];
- $self->{qv} = 1 if $value->{qv};
- $self->{alpha} = 1 if $value->{alpha};
- $self->{original} = ''.$value->{original};
- return $self;
- }
-
- if ( not defined $value or $value =~ /^undef$/ ) {
- # RT #19517 - special case for undef comparison
- # or someone forgot to pass a value
- push @{$self->{version}}, 0;
- $self->{original} = "0";
- return ($self);
- }
-
-
- if (ref($value) =~ m/ARRAY|HASH/) {
- require Carp;
- Carp::croak("Invalid version format (non-numeric data)");
- }
-
- $value = _un_vstring($value);
-
- if ($Config{d_setlocale}) {
- use POSIX qw/locale_h/;
- use if $Config{d_setlocale}, 'locale';
- my $currlocale = setlocale(LC_ALL);
-
- # if the current locale uses commas for decimal points, we
- # just replace commas with decimal places, rather than changing
- # locales
- if ( localeconv()->{decimal_point} eq ',' ) {
- $value =~ tr/,/./;
- }
- }
-
- # exponential notation
- if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
- $value = sprintf("%.9f",$value);
- $value =~ s/(0+)$//; # trim trailing zeros
- }
-
- my $s = scan_version($value, \$self, $qv);
-
- if ($s) { # must be something left over
- warn("Version string '%s' contains invalid data; "
- ."ignoring: '%s'", $value, $s);
- }
-
- return ($self);
- }
-
- *parse = \&new;
-
- sub numify {
- my ($self) = @_;
- unless (_verify($self)) {
- require Carp;
- Carp::croak("Invalid version object");
- }
- my $width = $self->{width} || 3;
- my $alpha = $self->{alpha} || "";
- my $len = $#{$self->{version}};
- my $digit = $self->{version}[0];
- my $string = sprintf("%d.", $digit );
-
- if ($alpha and warnings::enabled()) {
- warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy');
- }
-
- for ( my $i = 1 ; $i < $len ; $i++ ) {
- $digit = $self->{version}[$i];
- if ( $width < 3 ) {
- my $denom = 10**(3-$width);
- my $quot = int($digit/$denom);
- my $rem = $digit - ($quot * $denom);
- $string .= sprintf("%0".$width."d_%d", $quot, $rem);
- }
- else {
- $string .= sprintf("%03d", $digit);
- }
- }
-
- if ( $len > 0 ) {
- $digit = $self->{version}[$len];
- if ( $alpha && $width == 3 ) {
- $string .= "_";
- }
- $string .= sprintf("%0".$width."d", $digit);
- }
- else # $len = 0
- {
- $string .= sprintf("000");
- }
-
- return $string;
- }
-
- sub normal {
- my ($self) = @_;
- unless (_verify($self)) {
- require Carp;
- Carp::croak("Invalid version object");
- }
- my $alpha = $self->{alpha} || "";
- my $qv = $self->{qv} || "";
-
- my $len = $#{$self->{version}};
- my $digit = $self->{version}[0];
- my $string = sprintf("v%d", $digit );
-
- for ( my $i = 1 ; $i < $len ; $i++ ) {
- $digit = $self->{version}[$i];
- $string .= sprintf(".%d", $digit);
- }
-
- if ( $len > 0 ) {
- $digit = $self->{version}[$len];
- if ( $alpha ) {
- $string .= sprintf("_%0d", $digit);
- }
- else {
- $string .= sprintf(".%0d", $digit);
- }
- }
-
- if ( $len <= 2 ) {
- for ( $len = 2 - $len; $len != 0; $len-- ) {
- $string .= sprintf(".%0d", 0);
- }
- }
-
- return $string;
- }
-
- sub stringify {
- my ($self) = @_;
- unless (_verify($self)) {
- require Carp;
- Carp::croak("Invalid version object");
- }
- return exists $self->{original}
- ? $self->{original}
- : exists $self->{qv}
- ? $self->normal
- : $self->numify;
- }
-
- sub vcmp {
- require UNIVERSAL;
- my ($left,$right,$swap) = @_;
- my $class = ref($left);
- unless ( UNIVERSAL::isa($right, $class) ) {
- $right = $class->new($right);
- }
-
- if ( $swap ) {
- ($left, $right) = ($right, $left);
- }
- unless (_verify($left)) {
- require Carp;
- Carp::croak("Invalid version object");
- }
- unless (_verify($right)) {
- require Carp;
- Carp::croak("Invalid version format");
- }
- my $l = $#{$left->{version}};
- my $r = $#{$right->{version}};
- my $m = $l < $r ? $l : $r;
- my $lalpha = $left->is_alpha;
- my $ralpha = $right->is_alpha;
- my $retval = 0;
- my $i = 0;
- while ( $i <= $m && $retval == 0 ) {
- $retval = $left->{version}[$i] <=> $right->{version}[$i];
- $i++;
- }
-
- # tiebreaker for alpha with identical terms
- if ( $retval == 0
- && $l == $r
- && $left->{version}[$m] == $right->{version}[$m]
- && ( $lalpha || $ralpha ) ) {
-
- if ( $lalpha && !$ralpha ) {
- $retval = -1;
- }
- elsif ( $ralpha && !$lalpha) {
- $retval = +1;
- }
- }
-
- # possible match except for trailing 0's
- if ( $retval == 0 && $l != $r ) {
- if ( $l < $r ) {
- while ( $i <= $r && $retval == 0 ) {
- if ( $right->{version}[$i] != 0 ) {
- $retval = -1; # not a match after all
- }
- $i++;
- }
- }
- else {
- while ( $i <= $l && $retval == 0 ) {
- if ( $left->{version}[$i] != 0 ) {
- $retval = +1; # not a match after all
- }
- $i++;
- }
- }
- }
-
- return $retval;
- }
-
- sub vbool {
- my ($self) = @_;
- return vcmp($self,$self->new("0"),1);
- }
-
- sub vnoop {
- require Carp;
- Carp::croak("operation not supported with version object");
- }
-
- sub is_alpha {
- my ($self) = @_;
- return (exists $self->{alpha});
- }
-
- sub qv {
- my $value = shift;
- my $class = $CLASS;
- if (@_) {
- $class = ref($value) || $value;
- $value = shift;
- }
-
- $value = _un_vstring($value);
- $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
- my $obj = $CLASS->new($value);
- return bless $obj, $class;
- }
-
- *declare = \&qv;
-
- sub is_qv {
- my ($self) = @_;
- return (exists $self->{qv});
- }
-
-
- sub _verify {
- my ($self) = @_;
- if ( ref($self)
- && eval { exists $self->{version} }
- && ref($self->{version}) eq 'ARRAY'
- ) {
- return 1;
- }
- else {
- return 0;
- }
- }
-
- sub _is_non_alphanumeric {
- my $s = shift;
- $s = new charstar $s;
- while ($s) {
- return 0 if isSPACE($s); # early out
- return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
- $s++;
- }
- return 0;
- }
-
- sub _un_vstring {
- my $value = shift;
- # may be a v-string
- if ( length($value) >= 1 && $value !~ /[,._]/
- && _is_non_alphanumeric($value)) {
- my $tvalue;
- if ( $] >= 5.008_001 ) {
- $tvalue = _find_magic_vstring($value);
- $value = $tvalue if length $tvalue;
- }
- elsif ( $] >= 5.006_000 ) {
- $tvalue = sprintf("v%vd",$value);
- if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) {
- # must be a v-string
- $value = $tvalue;
- }
- }
- }
- return $value;
- }
-
- sub _find_magic_vstring {
- my $value = shift;
- my $tvalue = '';
- require B;
- my $sv = B::svref_2object(\$value);
- my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
- while ( $magic ) {
- if ( $magic->TYPE eq 'V' ) {
- $tvalue = $magic->PTR;
- $tvalue =~ s/^v?(.+)$/v$1/;
- last;
- }
- else {
- $magic = $magic->MOREMAGIC;
- }
- }
- return $tvalue;
- }
-
- sub _VERSION {
- my ($obj, $req) = @_;
- my $class = ref($obj) || $obj;
-
- no strict 'refs';
- if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
- # file but no package
- require Carp;
- Carp::croak( "$class defines neither package nor VERSION"
- ."--version check failed");
- }
-
- my $version = eval "\$$class\::VERSION";
- if ( defined $version ) {
- local $^W if $] <= 5.008;
- $version = version::vpp->new($version);
- }
-
- if ( defined $req ) {
- unless ( defined $version ) {
- require Carp;
- my $msg = $] < 5.006
- ? "$class version $req required--this is only version "
- : "$class does not define \$$class\::VERSION"
- ."--version check failed";
-
- if ( $ENV{VERSION_DEBUG} ) {
- Carp::confess($msg);
- }
- else {
- Carp::croak($msg);
- }
- }
-
- $req = version::vpp->new($req);
-
- if ( $req > $version ) {
- require Carp;
- if ( $req->is_qv ) {
- Carp::croak(
- sprintf ("%s version %s required--".
- "this is only version %s", $class,
- $req->normal, $version->normal)
- );
- }
- else {
- Carp::croak(
- sprintf ("%s version %s required--".
- "this is only version %s", $class,
- $req->stringify, $version->stringify)
- );
- }
- }
- }
-
- return defined $version ? $version->stringify : undef;
- }
-
- 1; #this line is important and will help the module return a true value
-X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VPP
-
-$fatpacked{"x86_64-linux-gnu-thread-multi/version/vxs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VXS';
- #!perl -w
- package version::vxs;
-
- use v5.10;
- use strict;
-
- use vars qw(@ISA $VERSION $CLASS );
- $VERSION = 0.9912;
- $CLASS = 'version::vxs';
-
- eval {
- require XSLoader;
- local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
- XSLoader::load('version::vxs', $VERSION);
- 1;
- } or do {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
- bootstrap version::vxs $VERSION;
- };
-
- # Preloaded methods go here.
-
- 1;
-X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VXS
-
s/^ //mg for values %fatpacked;
my $class = 'FatPacked::'.(0+\%fatpacked);
@@ -80501,15 +76428,17 @@ no strict 'refs';
if ($] < 5.008) {
*{"${class}::INC"} = sub {
- if (my $fat = $_[0]{$_[1]}) {
- return sub {
- return 0 unless length $fat;
- $fat =~ s/^([^\n]*\n?)//;
- $_ = $1;
- return 1;
- };
- }
- return;
+ if (my $fat = $_[0]{$_[1]}) {
+ my $pos = 0;
+ my $last = length $fat;
+ return (sub {
+ return 0 if $pos == $last;
+ my $next = (1 + index $fat, "\n", $pos) || $last;
+ $_ .= substr $fat, $pos, $next - $pos;
+ $pos = $next;
+ return 1;
+ });
+ }
};
}