In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/dec273dc8b9c0c21e9f60ba4897dd1052bfa4df9?hp=b50535da2f4aaf97d13e96cda0069755fb6bbf76>
- Log -----------------------------------------------------------------
commit dec273dc8b9c0c21e9f60ba4897dd1052bfa4df9
Author: Chris 'BinGOs' Williams <ch...@bingosnet.co.uk>
Date: Wed Jun 14 20:34:37 2017 +0100
Update JSON-PP to CPAN version 2.94
[DELTA]
2.94 2017-05-29
- fix a test to support perl 5.6
2.93 2017-05-15
- fix packaging issue
2.92 2017-05-15
- production release
2.91_04 2017-01-10
- fixed isa tests for bignum
2.91_03 2017-01-09
- reworked documentation, based on the one for JSON::XS
- let json_pp utility to show the version of JSON::PP
- applied a patch to fix loading order of B module (pali++)
2.91_02 2016-12-04
- fixed not to fail tests under Perl 5.25.* (srezic++)
2.91_01 2016-12-03
- changed the number detection logic, patched by haarg
(experimental)
- merged PR from dagolden to correct 0 handling
- removed base.pm dependency (dolmen)
- fixed wrong character offset spotted by ilmari
- applied patches from Jarkko Hietaniemi to address VAX issues
- small doc fixes from bessarabov, gregoa, Chris Anderson
- applied a patch to remove . in @INC in json_pp (Tony Cook)
- removed $VAR1 from json_pp output, spotted by tokuhirom
- fixed an issue to ignore trailing 0
- added Scalar::Util dependency for Perl 5.8+
- fixed issues spotted by Nicolas Seriot's JSON Test Suite
including experimental UTF-16/32 support and backward
incompatible change of C style comment handling (now disabled
by default)
- moved the guts of JSON::PP::Boolean into lib/JSON/PP/Boolean.pm
and gave it a proper version
- refactored incremental parser to let it handle incomplete
JSON text properly
- imported and tweaked tests from JSON.pm
- minor code clean up
M MANIFEST
M META.json
M Porting/Maintainers.pl
M cpan/JSON-PP/bin/json_pp
M cpan/JSON-PP/lib/JSON/PP.pm
M cpan/JSON-PP/lib/JSON/PP/Boolean.pm
M cpan/JSON-PP/t/001_utf8.t
M cpan/JSON-PP/t/002_error.t
M cpan/JSON-PP/t/003_types.t
M cpan/JSON-PP/t/006_pc_pretty.t
M cpan/JSON-PP/t/007_pc_esc.t
M cpan/JSON-PP/t/008_pc_base.t
M cpan/JSON-PP/t/009_pc_extra_number.t
M cpan/JSON-PP/t/010_pc_keysort.t
M cpan/JSON-PP/t/011_pc_expo.t
M cpan/JSON-PP/t/012_blessed.t
M cpan/JSON-PP/t/014_latin1.t
M cpan/JSON-PP/t/015_prefix.t
M cpan/JSON-PP/t/016_tied.t
M cpan/JSON-PP/t/017_relaxed.t
M cpan/JSON-PP/t/018_json_checker.t
M cpan/JSON-PP/t/019_incr.t
M cpan/JSON-PP/t/020_unknown.t
M cpan/JSON-PP/t/021_evans_bugrep.t
M cpan/JSON-PP/t/099_binary.t
M cpan/JSON-PP/t/110_bignum.t
M cpan/JSON-PP/t/113_overloaded_eq.t
M cpan/JSON-PP/t/114_decode_prefix.t
M cpan/JSON-PP/t/116_incr_parse_fixed.t
A cpan/JSON-PP/t/117_numbers.t
A cpan/JSON-PP/t/gh_28_json_test_suite.t
A cpan/JSON-PP/t/gh_29_trailing_false_value.t
A cpan/JSON-PP/t/rt_116998_wrong_character_offset.t
A cpan/JSON-PP/t/rt_90071_incr_parse.t
M cpan/JSON-PP/t/zero-mojibake.t
M t/porting/customized.dat
commit cc74493486f9024c5fe6b3bb6b9f9fd622dd5778
Author: Chris 'BinGOs' Williams <ch...@bingosnet.co.uk>
Date: Wed Jun 14 20:29:55 2017 +0100
Update File-Path to CPAN version 2.14
[DELTA]
2.14 2017-06-07
- When creating subdirectories for testing underneath
File::Spec::Functions::tmpdir(), use randomly generated strings.
- No change in functionality from 2.13.
2.13 2017-05-31
- Document security vulnerability reported as CVE-2017-6512.
2.12_008 2017-05-07
- Patch from John Lightsey.
2.12_007 2017-04-22
- Skip tests where filesystem doesn't support permissions (RT 121248).
- Add AppVeyor configuration; thanks to Charlie Gonzalez and Hayo Baan.
2.12_006 2017-04-21
- Modernize README, Makefile.PL, updating of version number
and release date in documentation.
2.12_005 2017-04-21
- Recommend use of 'safe => 1' in remove_tree() and rmtree().
- Warn if mkpath() or make_path() is passed implausible options on
Windows.
- Corrections to errors in previous release.
2.12_004 2017-04-18
- Certain functions used in tests are not available on Windows;
skip them.
- Move certain functions used in testing to t/FilePathTest.pm.
2.12_003 2017-04-07
- Add tests to improve coverage ratios as measured by Devel::Cover
- No functional changes.
2.12_002 2017-03-12
- GH#41 RT 117019 Fixed File::Path::remove_tree option hash is auto
populated and cannot be reused
- GH#40 Unskip in path root t
- GH#39 Remove superfluous assignment to $arg{perm}
- GH#38 Minor grammatical doc fixes.
- GH#37 Minor grammatical doc fixes.
2.12_001 2016-09-18
- RT 94209 document that the thread safety issue will not change and
communicate alternative.
- RT 85878 be more generous with error check regex given we could be
dealing with a pre-1.25 Carp.
- GH #33 Be more precise in documentation example for make_path
error checking.
- GH #34 Skip Windows 2000 and earlier unit tests (test change).
- GH #36 Do not hardcode ENOENT (test change).
M Porting/Maintainers.pl
M cpan/File-Path/lib/File/Path.pm
M cpan/File-Path/t/FilePathTest.pm
M cpan/File-Path/t/Path.t
M cpan/File-Path/t/Path_root.t
M cpan/File-Path/t/Path_win32.t
M t/porting/customized.dat
commit 34b02a7a9d74bd93db8f2e9eb73e8eff680e7113
Author: Chris 'BinGOs' Williams <ch...@bingosnet.co.uk>
Date: Wed Jun 14 20:23:55 2017 +0100
Update IPC-Cmd to CPAN version 0.98
[DELTA]
0.98 Fri May 12 17:00:07 BST 2017
Enhancements:
* Added wait_loop_callback for run_forked()
Bug fixes:
* Only search in curdir in can_run() when on Win32
RT#105601
M Porting/Maintainers.pl
M cpan/IPC-Cmd/lib/IPC/Cmd.pm
commit 7346c75ec710cdf1d2dd363f96aadd3522963f90
Author: Chris 'BinGOs' Williams <ch...@bingosnet.co.uk>
Date: Wed Jun 14 20:22:27 2017 +0100
Update Archive-Tar to CPAN version 2.26
[DELTA]
2.26 12/05/2017
- '0' is a valid name for an archive, change 'iter' to check definedness
M Porting/Maintainers.pl
M cpan/Archive-Tar/lib/Archive/Tar.pm
M cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
M cpan/Archive-Tar/lib/Archive/Tar/File.pm
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 5 +
META.json | 2 +-
Porting/Maintainers.pl | 16 +-
cpan/Archive-Tar/lib/Archive/Tar.pm | 5 +-
cpan/Archive-Tar/lib/Archive/Tar/Constant.pm | 2 +-
cpan/Archive-Tar/lib/Archive/Tar/File.pm | 2 +-
cpan/File-Path/lib/File/Path.pm | 491 ++++---
cpan/File-Path/t/FilePathTest.pm | 44 +-
cpan/File-Path/t/Path.t | 276 +++-
cpan/File-Path/t/Path_root.t | 40 +-
cpan/File-Path/t/Path_win32.t | 36 +-
cpan/IPC-Cmd/lib/IPC/Cmd.pm | 31 +-
cpan/JSON-PP/bin/json_pp | 11 +-
cpan/JSON-PP/lib/JSON/PP.pm | 1582 +++++++++++----------
cpan/JSON-PP/lib/JSON/PP/Boolean.pm | 23 +-
cpan/JSON-PP/t/001_utf8.t | 2 +-
cpan/JSON-PP/t/002_error.t | 2 +-
cpan/JSON-PP/t/003_types.t | 2 +-
cpan/JSON-PP/t/006_pc_pretty.t | 6 +-
cpan/JSON-PP/t/007_pc_esc.t | 10 +-
cpan/JSON-PP/t/008_pc_base.t | 4 +-
cpan/JSON-PP/t/009_pc_extra_number.t | 4 +-
cpan/JSON-PP/t/010_pc_keysort.t | 4 +-
cpan/JSON-PP/t/011_pc_expo.t | 6 +-
cpan/JSON-PP/t/012_blessed.t | 2 +-
cpan/JSON-PP/t/014_latin1.t | 2 +-
cpan/JSON-PP/t/015_prefix.t | 2 +-
cpan/JSON-PP/t/016_tied.t | 2 +-
cpan/JSON-PP/t/017_relaxed.t | 2 +-
cpan/JSON-PP/t/018_json_checker.t | 9 +-
cpan/JSON-PP/t/019_incr.t | 4 +-
cpan/JSON-PP/t/020_unknown.t | 4 +-
cpan/JSON-PP/t/021_evans_bugrep.t | 2 +-
cpan/JSON-PP/t/099_binary.t | 4 +-
cpan/JSON-PP/t/110_bignum.t | 15 +-
cpan/JSON-PP/t/113_overloaded_eq.t | 2 -
cpan/JSON-PP/t/114_decode_prefix.t | 2 -
cpan/JSON-PP/t/116_incr_parse_fixed.t | 2 -
cpan/JSON-PP/t/117_numbers.t | 23 +
cpan/JSON-PP/t/gh_28_json_test_suite.t | 59 +
cpan/JSON-PP/t/gh_29_trailing_false_value.t | 13 +
cpan/JSON-PP/t/rt_116998_wrong_character_offset.t | 22 +
cpan/JSON-PP/t/rt_90071_incr_parse.t | 29 +
cpan/JSON-PP/t/zero-mojibake.t | 2 -
t/porting/customized.dat | 6 -
45 files changed, 1722 insertions(+), 1092 deletions(-)
create mode 100644 cpan/JSON-PP/t/117_numbers.t
create mode 100644 cpan/JSON-PP/t/gh_28_json_test_suite.t
create mode 100644 cpan/JSON-PP/t/gh_29_trailing_false_value.t
create mode 100644 cpan/JSON-PP/t/rt_116998_wrong_character_offset.t
create mode 100644 cpan/JSON-PP/t/rt_90071_incr_parse.t
diff --git a/MANIFEST b/MANIFEST
index 34ae5b5a56..60f096c344 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1584,7 +1584,12 @@ cpan/JSON-PP/t/113_overloaded_eq.t
cpan/JSON-PP/t/114_decode_prefix.t
cpan/JSON-PP/t/115_tie_ixhash.t
cpan/JSON-PP/t/116_incr_parse_fixed.t
+cpan/JSON-PP/t/117_numbers.t
cpan/JSON-PP/t/_unicode_handling.pm
+cpan/JSON-PP/t/gh_28_json_test_suite.t
+cpan/JSON-PP/t/gh_29_trailing_false_value.t
+cpan/JSON-PP/t/rt_116998_wrong_character_offset.t
+cpan/JSON-PP/t/rt_90071_incr_parse.t
cpan/JSON-PP/t/zero-mojibake.t
cpan/libnet/lib/Net/Cmd.pm
cpan/libnet/lib/Net/Config.pm
diff --git a/META.json b/META.json
index 8b0b496f65..f06ed0f160 100644
--- a/META.json
+++ b/META.json
@@ -127,5 +127,5 @@
}
},
"version" : "5.027001",
- "x_serialization_backend" : "JSON::PP version 2.27400_02"
+ "x_serialization_backend" : "JSON::PP version 2.94"
}
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index ea985c5136..c8bdba6f00 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -120,7 +120,7 @@ use File::Glob qw(:case);
%Modules = (
'Archive::Tar' => {
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.24.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.26.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'BUGS' => 'bug-archive-...@rt.cpan.org',
'EXCLUDED' => [
@@ -494,14 +494,12 @@ use File::Glob qw(:case);
},
'File::Path' => {
- 'DISTRIBUTION' => 'RICHE/File-Path-2.12.tar.gz',
+ 'DISTRIBUTION' => 'JKEENAN/File-Path-2.14.tar.gz',
'FILES' => q[cpan/File-Path],
'EXCLUDED' => [
qw(t/Path-Class.t),
qr{^xt/},
],
- # https://github.com/rpcme/File-Path/pull/34
- 'CUSTOMIZED' => [ qw( lib/File/Path.pm t/Path_win32.t ) ],
},
'File::Temp' => {
@@ -633,7 +631,7 @@ use File::Glob qw(:case);
},
'IPC::Cmd' => {
- 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.96.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.98.tar.gz',
'FILES' => q[cpan/IPC-Cmd],
},
@@ -648,14 +646,8 @@ use File::Glob qw(:case);
},
'JSON::PP' => {
- 'DISTRIBUTION' => 'MAKAMAKA/JSON-PP-2.27400.tar.gz',
+ 'DISTRIBUTION' => 'ISHIGAKI/JSON-PP-2.94.tar.gz',
'FILES' => q[cpan/JSON-PP],
- 'CUSTOMIZED' => [
- 'bin/json_pp', # CVE-2016-1238
- 'lib/JSON/PP.pm', # CVE-2016-1238, CPAN RT 118469
- 't/011_pc_expo.t', # CPAN RT 118469
- 't/018_json_checker.t', # CPAN RT 118469
- ],
},
'lib' => {
diff --git a/cpan/Archive-Tar/lib/Archive/Tar.pm
b/cpan/Archive-Tar/lib/Archive/Tar.pm
index d63e586317..b585f7cfe2 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar.pm
@@ -31,7 +31,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK
$CHOWN $CHMOD
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "2.24";
+$VERSION = "2.26";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
@@ -1756,7 +1756,8 @@ Example usage:
sub iter {
my $class = shift;
- my $filename = shift or return;
+ my $filename = shift;
+ return unless defined $filename;
my $compressed = shift || 0;
my $opts = shift || {};
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
index 6488d653f9..aca1807a79 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
@@ -3,7 +3,7 @@ package Archive::Tar::Constant;
BEGIN {
require Exporter;
- $VERSION = '2.24';
+ $VERSION = '2.26';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
diff --git a/cpan/Archive-Tar/lib/Archive/Tar/File.pm
b/cpan/Archive-Tar/lib/Archive/Tar/File.pm
index dc4c4c77a0..deb11d2f78 100644
--- a/cpan/Archive-Tar/lib/Archive/Tar/File.pm
+++ b/cpan/Archive-Tar/lib/Archive/Tar/File.pm
@@ -13,7 +13,7 @@ use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '2.24';
+$VERSION = '2.26';
### set value to 1 to oct() it during the unpack ###
diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm
index 034da1e578..2b765e189f 100644
--- a/cpan/File-Path/lib/File/Path.pm
+++ b/cpan/File-Path/lib/File/Path.pm
@@ -18,7 +18,7 @@ BEGIN {
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = '2.12_01';
+$VERSION = '2.14';
$VERSION = eval $VERSION;
@ISA = qw(Exporter);
@EXPORT = qw(mkpath rmtree);
@@ -85,15 +85,15 @@ sub make_path {
sub mkpath {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
- my $arg;
+ my $data;
my $paths;
if ($old_style) {
my ( $verbose, $mode );
( $paths, $verbose, $mode ) = @_;
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
- $arg->{verbose} = $verbose;
- $arg->{mode} = defined $mode ? $mode : oct '777';
+ $data->{verbose} = $verbose;
+ $data->{mode} = defined $mode ? $mode : oct '777';
}
else {
my %args_permitted = map { $_ => 1 } ( qw|
@@ -107,55 +107,74 @@ sub mkpath {
user
verbose
| );
+ my %not_on_win32_args = map { $_ => 1 } ( qw|
+ group
+ owner
+ uid
+ user
+ | );
my @bad_args = ();
- $arg = pop @_;
+ my @win32_implausible_args = ();
+ my $arg = pop @_;
for my $k (sort keys %{$arg}) {
- push @bad_args, $k unless $args_permitted{$k};
- }
- _carp("Unrecognized option(s) passed to make_path(): @bad_args")
- if @bad_args;
- $arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
- $arg->{mode} = oct '777' unless exists $arg->{mode};
- ${ $arg->{error} } = [] if exists $arg->{error};
- $arg->{owner} = delete $arg->{user} if exists $arg->{user};
- $arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
- if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) {
- my $uid = ( getpwnam $arg->{owner} )[2];
- if ( defined $uid ) {
- $arg->{owner} = $uid;
+ if (! $args_permitted{$k}) {
+ push @bad_args, $k;
+ }
+ elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
+ push @win32_implausible_args, $k;
}
else {
- _error( $arg,
-"unable to map $arg->{owner} to a uid, ownership not changed"
- );
- delete $arg->{owner};
+ $data->{$k} = $arg->{$k};
}
}
- if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) {
- my $gid = ( getgrnam $arg->{group} )[2];
- if ( defined $gid ) {
- $arg->{group} = $gid;
+ _carp("Unrecognized option(s) passed to mkpath() or make_path():
@bad_args")
+ if @bad_args;
+ _carp("Option(s) implausible on Win32 passed to mkpath() or
make_path(): @win32_implausible_args")
+ if @win32_implausible_args;
+ $data->{mode} = delete $data->{mask} if exists $data->{mask};
+ $data->{mode} = oct '777' unless exists $data->{mode};
+ ${ $data->{error} } = [] if exists $data->{error};
+ unless (@win32_implausible_args) {
+ $data->{owner} = delete $data->{user} if exists $data->{user};
+ $data->{owner} = delete $data->{uid} if exists $data->{uid};
+ if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
+ my $uid = ( getpwnam $data->{owner} )[2];
+ if ( defined $uid ) {
+ $data->{owner} = $uid;
+ }
+ else {
+ _error( $data,
+ "unable to map $data->{owner} to a uid, ownership
not changed"
+ );
+ delete $data->{owner};
+ }
}
- else {
- _error( $arg,
-"unable to map $arg->{group} to a gid, group ownership not changed"
- );
- delete $arg->{group};
+ if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
+ my $gid = ( getgrnam $data->{group} )[2];
+ if ( defined $gid ) {
+ $data->{group} = $gid;
+ }
+ else {
+ _error( $data,
+ "unable to map $data->{group} to a gid, group
ownership not changed"
+ );
+ delete $data->{group};
+ }
+ }
+ if ( exists $data->{owner} and not exists $data->{group} ) {
+ $data->{group} = -1; # chown will leave group unchanged
+ }
+ if ( exists $data->{group} and not exists $data->{owner} ) {
+ $data->{owner} = -1; # chown will leave owner unchanged
}
- }
- if ( exists $arg->{owner} and not exists $arg->{group} ) {
- $arg->{group} = -1; # chown will leave group unchanged
- }
- if ( exists $arg->{group} and not exists $arg->{owner} ) {
- $arg->{owner} = -1; # chown will leave owner unchanged
}
$paths = [@_];
}
- return _mkpath( $arg, $paths );
+ return _mkpath( $data, $paths );
}
sub _mkpath {
- my $arg = shift;
+ my $data = shift;
my $paths = shift;
my ( @created );
@@ -170,38 +189,51 @@ sub _mkpath {
}
next if -d $path;
my $parent = File::Basename::dirname($path);
+ # Coverage note: It's not clear how we would test the condition:
+ # '-d $parent or $path eq $parent'
unless ( -d $parent or $path eq $parent ) {
- push( @created, _mkpath( $arg, [$parent] ) );
+ push( @created, _mkpath( $data, [$parent] ) );
}
- print "mkdir $path\n" if $arg->{verbose};
- if ( mkdir( $path, $arg->{mode} ) ) {
+ print "mkdir $path\n" if $data->{verbose};
+ if ( mkdir( $path, $data->{mode} ) ) {
push( @created, $path );
- if ( exists $arg->{owner} ) {
+ if ( exists $data->{owner} ) {
- # NB: $arg->{group} guaranteed to be set during initialisation
- if ( !chown $arg->{owner}, $arg->{group}, $path ) {
- _error( $arg,
-"Cannot change ownership of $path to $arg->{owner}:$arg->{group}"
+ # NB: $data->{group} guaranteed to be set during initialisation
+ if ( !chown $data->{owner}, $data->{group}, $path ) {
+ _error( $data,
+ "Cannot change ownership of $path to
$data->{owner}:$data->{group}"
);
}
}
- if ( exists $arg->{chmod} ) {
- if ( !chmod $arg->{chmod}, $path ) {
- _error( $arg,
- "Cannot change permissions of $path to $arg->{chmod}"
);
+ if ( exists $data->{chmod} ) {
+ # Coverage note: It's not clear how we would trigger the next
+ # 'if' block. Failure of 'chmod' might first result in a
+ # system error: "Permission denied".
+ if ( !chmod $data->{chmod}, $path ) {
+ _error( $data,
+ "Cannot change permissions of $path to $data->{chmod}"
);
}
}
}
else {
my $save_bang = $!;
+
+ # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
+ # as:
+ # Error information specific to the current operating system. At
the
+ # moment, this differs from "$!" under only VMS, OS/2, and Win32
+ # (and for MacPerl). On all other platforms, $^E is always just the
+ # same as $!.
+
my ( $e, $e1 ) = ( $save_bang, $^E );
$e .= "; $e1" if $e ne $e1;
# allow for another process to have created it meanwhile
if ( ! -d $path ) {
$! = $save_bang;
- if ( $arg->{error} ) {
- push @{ ${ $arg->{error} } }, { $path => $e };
+ if ( $data->{error} ) {
+ push @{ ${ $data->{error} } }, { $path => $e };
}
else {
_croak("mkdir $path: $e");
@@ -238,14 +270,13 @@ sub _is_subdir {
sub rmtree {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
- my $arg;
- my $paths;
+ my ($arg, $data, $paths);
if ($old_style) {
my ( $verbose, $safe );
( $paths, $verbose, $safe ) = @_;
- $arg->{verbose} = $verbose;
- $arg->{safe} = defined $safe ? $safe : 0;
+ $data->{verbose} = $verbose;
+ $data->{safe} = defined $safe ? $safe : 0;
if ( defined($paths) and length($paths) ) {
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
@@ -264,38 +295,53 @@ sub rmtree {
verbose
| );
my @bad_args = ();
- $arg = pop @_;
+ my $arg = pop @_;
for my $k (sort keys %{$arg}) {
- push @bad_args, $k unless $args_permitted{$k};
+ if (! $args_permitted{$k}) {
+ push @bad_args, $k;
+ }
+ else {
+ $data->{$k} = $arg->{$k};
+ }
}
_carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
if @bad_args;
- ${ $arg->{error} } = [] if exists $arg->{error};
- ${ $arg->{result} } = [] if exists $arg->{result};
+ ${ $data->{error} } = [] if exists $data->{error};
+ ${ $data->{result} } = [] if exists $data->{result};
+
+ # Wouldn't it make sense to do some validation on @_ before assigning
+ # to $paths here?
+ # In the $old_style case we guarantee that each path is both defined
+ # and non-empty. We don't check that here, which means we have to
+ # check it later in the first condition in this line:
+ # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd )
) {
+ # Granted, that would be a change in behavior for the two
+ # non-old-style interfaces.
+
$paths = [@_];
}
- $arg->{prefix} = '';
- $arg->{depth} = 0;
+ $data->{prefix} = '';
+ $data->{depth} = 0;
my @clean_path;
- $arg->{cwd} = getcwd() or do {
- _error( $arg, "cannot fetch initial working directory" );
+ $data->{cwd} = getcwd() or do {
+ _error( $data, "cannot fetch initial working directory" );
return 0;
};
- for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
+ for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
for my $p (@$paths) {
# need to fixup case and map \ to / on Windows
my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
my $ortho_cwd =
- _IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd};
+ _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
my $ortho_root_length = length($ortho_root);
$ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
local $! = 0;
- _error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p );
+ _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
next;
}
@@ -312,16 +358,16 @@ sub rmtree {
push @clean_path, $p;
}
- @{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do {
- _error( $arg, "cannot stat initial working directory", $arg->{cwd} );
+ @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
+ _error( $data, "cannot stat initial working directory", $data->{cwd} );
return 0;
};
- return _rmtree( $arg, \@clean_path );
+ return _rmtree( $data, \@clean_path );
}
sub _rmtree {
- my $arg = shift;
+ my $data = shift;
my $paths = shift;
my $count = 0;
@@ -339,8 +385,8 @@ sub _rmtree {
# opposed to being truly canonical, anchored from the root (/).
my $canon =
- $arg->{prefix}
- ? File::Spec->catfile( $arg->{prefix}, $root )
+ $data->{prefix}
+ ? File::Spec->catfile( $data->{prefix}, $root )
: $root;
my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
@@ -354,29 +400,40 @@ sub _rmtree {
# see if we can escalate privileges to get in
# (e.g. funny protection mask such as -w- instead of rwx)
- $perm &= oct '7777';
- my $nperm = $perm | oct '700';
- if (
- !(
- $arg->{safe}
- or $nperm == $perm
- or chmod( $nperm, $root )
- )
- )
- {
- _error( $arg,
- "cannot make child directory read-write-exec", $canon
);
- next ROOT_DIR;
+ # This uses fchmod to avoid traversing outside of the proper
+ # location (CVE-2017-6512)
+ my $root_fh;
+ if (open($root_fh, '<', $root)) {
+ my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
+ $perm &= oct '7777';
+ my $nperm = $perm | oct '700';
+ local $@;
+ if (
+ !(
+ $data->{safe}
+ or $nperm == $perm
+ or !-d _
+ or $fh_dev ne $ldev
+ or $fh_inode ne $lino
+ or eval { chmod( $nperm, $root_fh ) }
+ )
+ )
+ {
+ _error( $data,
+ "cannot make child directory read-write-exec",
$canon );
+ next ROOT_DIR;
+ }
+ close $root_fh;
}
- elsif ( !chdir($root) ) {
- _error( $arg, "cannot chdir to child", $canon );
+ if ( !chdir($root) ) {
+ _error( $data, "cannot chdir to child", $canon );
next ROOT_DIR;
}
}
my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
or do {
- _error( $arg, "cannot stat current working directory", $canon
);
+ _error( $data, "cannot stat current working directory", $canon
);
next ROOT_DIR;
};
@@ -397,20 +454,20 @@ sub _rmtree {
if (
!(
- $arg->{safe}
+ $data->{safe}
or $nperm == $perm
or chmod( $nperm, $curdir )
)
)
{
- _error( $arg, "cannot make directory read+writeable", $canon );
+ _error( $data, "cannot make directory read+writeable", $canon
);
$nperm = $perm;
}
my $d;
$d = gensym() if $] < 5.006;
if ( !opendir $d, $curdir ) {
- _error( $arg, "cannot opendir", $canon );
+ _error( $data, "cannot opendir", $canon );
@files = ();
}
else {
@@ -437,9 +494,9 @@ sub _rmtree {
if (@files) {
# remove the contained files before the directory itself
- my $narg = {%$arg};
+ my $narg = {%$data};
@{$narg}{qw(device inode cwd prefix depth)} =
- ( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 );
+ ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
$count += _rmtree( $narg, \@files );
}
@@ -447,49 +504,49 @@ sub _rmtree {
# below fails), while we are still in the directory and may do so
# without a race via '.'
if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
- _error( $arg, "cannot reset chmod", $canon );
+ _error( $data, "cannot reset chmod", $canon );
}
# don't leave the client code in an unexpected directory
- chdir( $arg->{cwd} )
+ chdir( $data->{cwd} )
or
- _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
+ _croak("cannot chdir to $data->{cwd} from $canon: $!,
aborting.");
# ensure that a chdir upwards didn't take us somewhere other
# than we expected (see CVE-2002-0435)
( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
or _croak(
- "cannot stat prior working directory $arg->{cwd}: $!,
aborting."
+ "cannot stat prior working directory $data->{cwd}: $!,
aborting."
);
if (_NEED_STAT_CHECK) {
- ( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode )
- or _croak( "previous directory $arg->{cwd} "
+ ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode
)
+ or _croak( "previous directory $data->{cwd} "
. "changed before entering $canon, "
. "expected dev=$ldev ino=$lino, "
. "actual dev=$cur_dev ino=$cur_inode, aborting."
);
}
- if ( $arg->{depth} or !$arg->{keep_root} ) {
- if ( $arg->{safe}
+ if ( $data->{depth} or !$data->{keep_root} ) {
+ if ( $data->{safe}
&& ( _IS_VMS
? !&VMS::Filespec::candelete($root)
: !-w $root ) )
{
- print "skipped $root\n" if $arg->{verbose};
+ print "skipped $root\n" if $data->{verbose};
next ROOT_DIR;
}
if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
- _error( $arg, "cannot make directory writeable", $canon );
+ _error( $data, "cannot make directory writeable", $canon );
}
- print "rmdir $root\n" if $arg->{verbose};
+ print "rmdir $root\n" if $data->{verbose};
if ( rmdir $root ) {
- push @{ ${ $arg->{result} } }, $root if $arg->{result};
+ push @{ ${ $data->{result} } }, $root if $data->{result};
++$count;
}
else {
- _error( $arg, "cannot remove directory", $canon );
+ _error( $data, "cannot remove directory", $canon );
if (
_FORCE_WRITABLE
&& !chmod( $perm,
@@ -498,7 +555,7 @@ sub _rmtree {
)
{
_error(
- $arg,
+ $data,
sprintf( "cannot restore permissions to 0%o",
$perm ),
$canon
@@ -515,7 +572,7 @@ sub _rmtree {
&& ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
if (
- $arg->{safe}
+ $data->{safe}
&& (
_IS_VMS
? !&VMS::Filespec::candelete($root)
@@ -523,7 +580,7 @@ sub _rmtree {
)
)
{
- print "skipped $root\n" if $arg->{verbose};
+ print "skipped $root\n" if $data->{verbose};
next ROOT_DIR;
}
@@ -532,19 +589,19 @@ sub _rmtree {
and $nperm != $perm
and not chmod $nperm, $root )
{
- _error( $arg, "cannot make file writeable", $canon );
+ _error( $data, "cannot make file writeable", $canon );
}
- print "unlink $canon\n" if $arg->{verbose};
+ print "unlink $canon\n" if $data->{verbose};
# delete all versions under VMS
for ( ; ; ) {
if ( unlink $root ) {
- push @{ ${ $arg->{result} } }, $root if $arg->{result};
+ push @{ ${ $data->{result} } }, $root if $data->{result};
}
else {
- _error( $arg, "cannot unlink file", $canon );
+ _error( $data, "cannot unlink file", $canon );
_FORCE_WRITABLE and chmod( $perm, $root )
- or _error( $arg,
+ or _error( $data,
sprintf( "cannot restore permissions to 0%o", $perm ),
$canon );
last;
@@ -576,41 +633,41 @@ File::Path - Create or remove directory trees
=head1 VERSION
-This document describes version 2.12 of File::Path.
+2.14 - released June 07 2016.
=head1 SYNOPSIS
- use File::Path qw(make_path remove_tree);
-
- @created = make_path('foo/bar/baz', '/zug/zwang');
- @created = make_path('foo/bar/baz', '/zug/zwang', {
- verbose => 1,
- mode => 0711,
- });
- make_path('foo/bar/baz', '/zug/zwang', {
- chmod => 0777,
- });
-
- $removed_count = remove_tree('foo/bar/baz', '/zug/zwang');
- $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', {
- verbose => 1,
- error => \my $err_list,
- });
-
- # legacy (interface promoted before v2.00)
- @created = mkpath('/foo/bar/baz');
- @created = mkpath('/foo/bar/baz', 1, 0711);
- @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
- $removed_count = rmtree('foo/bar/baz', 1, 1);
- $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
-
- # legacy (interface promoted before v2.06)
- @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711
});
- $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode =>
0711 });
+ use File::Path qw(make_path remove_tree);
+
+ @created = make_path('foo/bar/baz', '/zug/zwang');
+ @created = make_path('foo/bar/baz', '/zug/zwang', {
+ verbose => 1,
+ mode => 0711,
+ });
+ make_path('foo/bar/baz', '/zug/zwang', {
+ chmod => 0777,
+ });
+
+ $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', {
+ verbose => 1,
+ error => \my $err_list,
+ safe => 1,
+ });
+
+ # legacy (interface promoted before v2.00)
+ @created = mkpath('/foo/bar/baz');
+ @created = mkpath('/foo/bar/baz', 1, 0711);
+ @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
+ $removed_count = rmtree('foo/bar/baz', 1, 1);
+ $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
+
+ # legacy (interface promoted before v2.06)
+ @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode =>
0711 });
+ $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode
=> 0711 });
=head1 DESCRIPTION
-This module provide a convenient way to create directories of
+This module provides a convenient way to create directories of
arbitrary depth and to delete an entire directory subtree from the
filesystem.
@@ -623,7 +680,7 @@ The following functions are provided:
=item make_path( $dir1, $dir2, ...., \%opts )
The C<make_path> function creates the given directories if they don't
-exists before, much like the Unix command C<mkdir -p>.
+exist before, much like the Unix command C<mkdir -p>.
The function accepts a list of directories to be created. Its
behaviour may be tuned by an optional hashref appearing as the last
@@ -639,7 +696,7 @@ The following keys are recognised in the option hash:
=item mode => $num
The numeric permissions mode to apply to each created directory
-(defaults to 0777), to be modified by the current C<umask>. If the
+(defaults to C<0777>), to be modified by the current C<umask>. If the
directory already exists (and thus does not need to be created),
the permissions will not be modified.
@@ -675,9 +732,9 @@ in an C<eval> block.
=item uid => $owner
If present, will cause any created directory to be owned by C<$owner>.
-If the value is numeric, it will be interpreted as a uid, otherwise
-as username is assumed. An error will be issued if the username cannot be
-mapped to a uid, or the uid does not exist, or the process lacks the
+If the value is numeric, it will be interpreted as a uid; otherwise a
+username is assumed. An error will be issued if the username cannot be
+mapped to a uid, the uid does not exist or the process lacks the
privileges to change ownership.
Ownership of directories that already exist will not be changed.
@@ -686,11 +743,11 @@ C<user> and C<uid> are aliases of C<owner>.
=item group => $group
-If present, will cause any created directory to be owned by the group
C<$group>.
-If the value is numeric, it will be interpreted as a gid, otherwise
-as group name is assumed. An error will be issued if the group name cannot be
-mapped to a gid, or the gid does not exist, or the process lacks the
-privileges to change group ownership.
+If present, will cause any created directory to be owned by the group
+C<$group>. If the value is numeric, it will be interpreted as a gid;
+otherwise a group name is assumed. An error will be issued if the
+group name cannot be mapped to a gid, the gid does not exist or the
+process lacks the privileges to change group ownership.
Group ownership of directories that already exist will not be changed.
@@ -706,9 +763,10 @@ Group ownership of directories that already exist will not
be changed.
=item mkpath( $dir1, $dir2,..., \%opt )
-The mkpath() function provide the legacy interface of make_path() with
-a different interpretation of the arguments passed. The behaviour and
-return value of the function is otherwise identical to make_path().
+The C<mkpath()> function provide the legacy interface of
+C<make_path()> with a different interpretation of the arguments
+passed. The behaviour and return value of the function is otherwise
+identical to C<make_path()>.
=item remove_tree( $dir1, $dir2, .... )
@@ -716,16 +774,27 @@ return value of the function is otherwise identical to
make_path().
The C<remove_tree> function deletes the given directories and any
files and subdirectories they might contain, much like the Unix
-command C<rm -r> or the Windows commands C<rmdir /s> and C<rd /s>. The
-only exception to the function similarity is C<remove_tree> accepts
-only directories whereas C<rm -r> also accepts files.
+command C<rm -rf> or the Windows commands C<rmdir /s> and C<rd /s>. The
+only exception to the function similarity is that C<remove_tree> accepts
+only directories whereas C<rm -rf> also accepts files.
The function accepts a list of directories to be
removed. Its behaviour may be tuned by an optional hashref
appearing as the last parameter on the call. If an empty string is
passed to C<remove_tree>, an error will occur.
-The functions returns the number of files successfully deleted.
+B<NOTE:> For security reasons, we strongly advise use of the
+hashref-as-final-argument syntax -- specifically, with a setting of the C<safe>
+element to a true value.
+
+ remove_tree( $dir1, $dir2, ....,
+ {
+ safe => 1,
+ ... # other key-value pairs
+ },
+ );
+
+The function returns the number of files successfully deleted.
The following keys are recognised in the option hash:
@@ -751,7 +820,7 @@ When set to a true value, will cause all files and
subdirectories
to be removed, except the initially specified directories. This comes
in handy when cleaning out an application's scratch directory.
- remove_tree( '/tmp', {keep_root => 1} );
+ remove_tree( '/tmp', {keep_root => 1} );
=item result => \$res
@@ -760,8 +829,8 @@ This scalar will be made to reference an array, which will
be used to store all files and directories unlinked
during the call. If nothing is unlinked, the array will be empty.
- remove_tree( '/tmp', {result => \my $list} );
- print "unlinked $_\n" for @$list;
+ remove_tree( '/tmp', {result => \my $list} );
+ print "unlinked $_\n" for @$list;
This is a useful alternative to the C<verbose> key.
@@ -791,10 +860,21 @@ of hand. This is the safest course of action.
=item rmtree( $dir1, $dir2,..., \%opt )
-The rmtree() function provide the legacy interface of remove_tree()
-with a different interpretation of the arguments passed. The behaviour
-and return value of the function is otherwise identical to
-remove_tree().
+The C<rmtree()> function provide the legacy interface of
+C<remove_tree()> with a different interpretation of the arguments
+passed. The behaviour and return value of the function is otherwise
+identical to C<remove_tree()>.
+
+B<NOTE:> For security reasons, we strongly advise use of the
+hashref-as-final-argument syntax, specifically with a setting of the C<safe>
+element to a true value.
+
+ rmtree( $dir1, $dir2, ....,
+ {
+ safe => 1,
+ ... # other key-value pairs
+ },
+ );
=back
@@ -813,9 +893,9 @@ C<make_path> or C<remove_tree>, you should take additional
precautions.
=back
-If C<make_path> or C<remove_tree> encounter an error, a diagnostic
+If C<make_path> or C<remove_tree> encounters an error, a diagnostic
message will be printed to C<STDERR> via C<carp> (for non-fatal
-errors), or via C<croak> (for fatal errors).
+errors) or via C<croak> (for fatal errors).
If this behaviour is not desirable, the C<error> attribute may be
used to hold a reference to a variable, which will be used to store
@@ -828,7 +908,7 @@ encountered the diagnostic key will be empty.
An example usage looks like:
remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
- if (@$err) {
+ if ($err && @$err) {
for my $diag (@$err) {
my ($file, $message) = %$diag;
if ($file eq '') {
@@ -882,16 +962,16 @@ to at least 2.08 in order to avoid surprises.
=head3 SECURITY CONSIDERATIONS
-There were race conditions 1.x implementations of File::Path's
+There were race conditions in the 1.x implementations of File::Path's
C<rmtree> function (although sometimes patched depending on the OS
distribution or platform). The 2.0 version contains code to avoid the
problem mentioned in CVE-2002-0435.
See the following pages for more information:
- http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
- http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
- http://www.debian.org/security/2005/dsa-696
+ http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
+ http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
+ http://www.debian.org/security/2005/dsa-696
Additionally, unless the C<safe> parameter is set (or the
third parameter in the traditional interface is TRUE), should a
@@ -899,6 +979,27 @@ C<remove_tree> be interrupted, files that were originally
in read-only
mode may now have their permissions set to a read-write (or "delete
OK") mode.
+The following CVE reports were previously filed against File-Path and are
+believed to have been addressed:
+
+=over 4
+
+=item * L<http://cve.circl.lu/cve/CVE-2004-0452>
+
+=item * L<http://cve.circl.lu/cve/CVE-2005-0448>
+
+=back
+
+In February 2017 the cPanel Security Team reported an additional vulnerability
+in File-Path. The C<chmod()> logic to make directories traversable can be
+abused to set the mode on an attacker-chosen file to an attacker-chosen value.
+This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition
+(L<https://en.wikipedia.org/wiki/Time_of_check_to_time_of_use>) between the
+C<stat()> that decides the inode is a directory and the C<chmod()> that tries
+to make it user-rwx. CPAN versions 2.13 and later incorporate a patch
+provided by John Lightsey to address this problem. This vulnerability has
+been reported as CVE-2017-6512.
+
=head1 DIAGNOSTICS
FATAL errors will cause the program to halt (C<croak>), since the
@@ -907,7 +1008,7 @@ can always be trapped with C<eval>, but it's not a good
idea. Under
the circumstances, dying is the best thing to do).
SEVERE errors may be trapped using the modern interface. If the
-they are not trapped, or the old interface is used, such an error
+they are not trapped, or if the old interface is used, such an error
will cause the program will halt.
All other errors may be trapped using the modern interface, otherwise
@@ -918,7 +1019,7 @@ they will be C<carp>ed about. Program execution will not
be halted.
=item mkdir [path]: [errmsg] (SEVERE)
C<make_path> was unable to create the path. Probably some sort of
-permissions error at the point of departure, or insufficient resources
+permissions error at the point of departure or insufficient resources
(such as free inodes on Unix).
=item No root path(s) specified
@@ -997,7 +1098,7 @@ halts to avoid a race condition from occurring.
=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
-C<remove_tree> was unable to stat the parent directory after have returned
+C<remove_tree> was unable to stat the parent directory after having returned
from the child. Since there is no way of knowing if we returned to
where we think we should be (by comparing device and inode) the only
way out is to C<croak>.
@@ -1017,9 +1118,9 @@ execution continues, but the directory may possibly not
be deleted.
=item cannot remove directory [dir]: [errmsg]
-C<remove_tree> attempted to remove a directory, but failed. This may because
+C<remove_tree> attempted to remove a directory, but failed. This may be because
some objects that were unable to be removed remain in the directory, or
-a permissions issue. The directory will be left behind.
+it could be a permissions issue. The directory will be left behind.
=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
@@ -1087,14 +1188,16 @@ to examining directory trees.
The following describes F<File::Path> limitations and how to report bugs.
-=head2 MULTITHREAD APPLICATIONS
+=head2 MULTITHREADED APPLICATIONS
-F<File::Path> B<rmtree> and B<remove_tree> will not work with multithreaded
-applications due to its use of B<chdir>. At this time, no warning or error
-results and you will certainly encounter unexpected results.
+F<File::Path> C<rmtree> and C<remove_tree> will not work with
+multithreaded applications due to its use of C<chdir>. At this time,
+no warning or error is generated in this situation. You will
+certainly encounter unexpected results.
-The implementation that surfaces this limitation may change in a future
-release.
+The implementation that surfaces this limitation will not be changed. See the
+F<File::Path::Tiny> module for functionality similar to F<File::Path> but
which does
+not C<chdir>.
=head2 NFS Mount Points
@@ -1141,14 +1244,22 @@ James (Jim) Keenan <F<jkee...@cpan.org>>.
=head1 CONTRIBUTORS
-Contributors to File::Path, in alphabetical order.
+Contributors to File::Path, in alphabetical order by first name.
=over 1
=item <F<bul...@cpan.org>>
+=item Charlie Gonzalez <F<itchar...@cpan.org>>
+
=item Craig A. Berry <F<craigbe...@mac.com>>
+=item James E Keenan <F<jkee...@cpan.org>>
+
+=item John Lightsey <F<j...@perlsec.org>>
+
+=item Nigel Horne <F<n...@bandsman.co.uk>>
+
=item Richard Elberger <F<ri...@cpan.org>>
=item Ryan Yee <F<r...@cpan.org>>
@@ -1157,12 +1268,14 @@ Contributors to File::Path, in alphabetical order.
=item Tom Lutz <F<tommyl...@gmail.com>>
+=item Will Sheppard <F<willsheppard@github>>
+
=back
=head1 COPYRIGHT
This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren,
-James Keenan, and Richard Elberger 1995-2015. All rights reserved.
+James Keenan and Richard Elberger 1995-2017. All rights reserved.
=head1 LICENSE
diff --git a/cpan/File-Path/t/FilePathTest.pm b/cpan/File-Path/t/FilePathTest.pm
index f9e8289311..88b411d4bb 100644
--- a/cpan/File-Path/t/FilePathTest.pm
+++ b/cpan/File-Path/t/FilePathTest.pm
@@ -3,18 +3,26 @@ use strict;
use warnings;
use base 'Exporter';
use SelectSaver;
+use Carp;
use Cwd;
use File::Spec::Functions;
+use File::Path ();
+use Test::More ();
-our @EXPORT = qw(_run_for_warning _run_for_verbose _basedir
- _cannot_delete_safe_mode
- _verbose_expected);
+our @EXPORT_OK = qw(
+ _run_for_warning
+ _run_for_verbose
+ _cannot_delete_safe_mode
+ _verbose_expected
+ create_3_level_subdirs
+ cleanup_3_level_subdirs
+);
sub _basedir {
- return catdir( curdir(),
- sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+ return catdir(
+ curdir(),
+ sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
);
-
}
sub _run_for_warning {
@@ -109,4 +117,28 @@ END
}
}
+sub create_3_level_subdirs {
+ my @dirnames = @_;
+ my %seen = map {$_ => 1} @dirnames;
+ croak "Need 3 distinct names for subdirectories"
+ unless scalar(keys %seen) == 3;
+ my $tdir = File::Spec::Functions::tmpdir();
+ my $least_deep = catdir($tdir, $dirnames[0]);
+ my $next_deepest = catdir($least_deep, $dirnames[1]);
+ my $deepest = catdir($next_deepest, $dirnames[2]);
+ return ($least_deep, $next_deepest, $deepest);
+}
+
+sub cleanup_3_level_subdirs {
+ # runs 2 tests
+ my $least_deep = shift;
+ croak "Must provide path of least subdirectory"
+ unless (length($least_deep) and (-d $least_deep));
+ my $x;
+ my $opts = { error => \$x };
+ File::Path::remove_tree($least_deep, $opts);
+ Test::More::ok(! -d $least_deep, "directory '$least_deep' removed, as
expected");
+ Test::More::is(scalar(@{$x}), 0, "no error messages using remove_tree()
with \$opts");
+}
+
1;
diff --git a/cpan/File-Path/t/Path.t b/cpan/File-Path/t/Path.t
index 5644f57a51..7eb85721e9 100644
--- a/cpan/File-Path/t/Path.t
+++ b/cpan/File-Path/t/Path.t
@@ -3,11 +3,20 @@
use strict;
-use Test::More tests => 127;
+use Test::More tests => 167;
use Config;
use Fcntl ':mode';
-use lib 't/';
-use FilePathTest;
+use lib './t';
+use FilePathTest qw(
+ _run_for_warning
+ _run_for_verbose
+ _cannot_delete_safe_mode
+ _verbose_expected
+ create_3_level_subdirs
+ cleanup_3_level_subdirs
+);
+use Errno qw(:POSIX);
+use Carp;
BEGIN {
use_ok('Cwd');
@@ -17,6 +26,13 @@ BEGIN {
my $Is_VMS = $^O eq 'VMS';
+my $fchmod_supported = 0;
+if (open my $fh, curdir()) {
+ my ($perm) = (stat($fh))[2];
+ $perm &= 07777;
+ eval { $fchmod_supported = chmod( $perm, $fh); };
+}
+
# first check for stupid permissions second for full, so we clean up
# behind ourselves
for my $perm (0111,0777) {
@@ -298,16 +314,19 @@ is($created[0], $dir, "created directory (old style 3
mode undef) cross-check");
is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
-$dir = catdir($tmp_base,'G');
-$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+SKIP: {
+ skip "fchmod of directories not supported on this platform", 3 unless
$fchmod_supported;
+ $dir = catdir($tmp_base,'G');
+ $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
-@created = mkpath($dir, undef, 0200);
+ @created = mkpath($dir, undef, 0400);
-is(scalar(@created), 1, "created write-only dir");
+ is(scalar(@created), 1, "created read-only dir");
-is($created[0], $dir, "created write-only directory cross-check");
+ is($created[0], $dir, "created read-only directory cross-check");
-is(rmtree($dir), 1, "removed write-only dir");
+ is(rmtree($dir), 1, "removed read-only dir");
+}
# borderline new-style heuristics
if (chdir $tmp_base) {
@@ -449,26 +468,28 @@ SKIP: {
}
SKIP : {
- my $skip_count = 19;
+ my $skip_count = 18;
# this test will fail on Windows, as per:
# http://perldoc.perl.org/perlport.html#chmod
skip "Windows chmod test skipped", $skip_count
if $^O eq 'MSWin32';
+ skip "fchmod() on directories is not supported on this platform",
$skip_count
+ unless $fchmod_supported;
my $mode;
my $octal_mode;
my @inputs = (
- 0777, 0700, 0070, 0007,
- 0333, 0300, 0030, 0003,
- 0111, 0100, 0010, 0001,
- 0731, 0713, 0317, 0371, 0173, 0137,
- 00 );
+ 0777, 0700, 0470, 0407,
+ 0433, 0400, 0430, 0403,
+ 0111, 0100, 0110, 0101,
+ 0731, 0713, 0317, 0371,
+ 0173, 0137);
my $input;
my $octal_input;
- $dir = catdir($tmp_base, 'chmod_test');
foreach (@inputs) {
$input = $_;
+ $dir = catdir($tmp_base, sprintf("chmod_test%04o", $input));
# We can skip from here because 0 is last in the list.
skip "Mode of 0 means assume user defaults on VMS", 1
if ($input == 0 && $Is_VMS);
@@ -476,7 +497,11 @@ SKIP : {
$mode = (stat($dir))[2];
$octal_mode = S_IMODE($mode);
$octal_input = sprintf "%04o", S_IMODE($input);
- is($octal_mode,$input, "create a new directory with chmod $input
($octal_input)");
+ SKIP: {
+ skip "permissions are not fully supported by the filesystem", 1
+ if (($^O eq 'MSWin32' || $^O eq 'cygwin') &&
((Win32::FsType())[1] & 8) == 0);
+ is($octal_mode,$input, "create a new directory with chmod $input
($octal_input)");
+ }
rmtree( $dir );
}
}
@@ -587,29 +612,27 @@ SKIP: {
my $dir2 = catdir( $base, 'B');
{
- my $warn;
- $SIG{__WARN__} = sub { $warn = shift };
-
- my @created = make_path(
- $dir,
- $dir2,
- { mode => 0711, foo => 1, bar => 1 }
- );
+ my $warn = _run_for_warning( sub {
+ my @created = make_path(
+ $dir,
+ $dir2,
+ { mode => 0711, foo => 1, bar => 1 }
+ );
+ } );
like($warn,
- qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/,
+ qr/Unrecognized option\(s\) passed to mkpath\(\) or
make_path\(\):.*?bar.*?foo/,
'make_path with final hashref warned due to unrecognized options'
);
}
{
- my $warn;
- $SIG{__WARN__} = sub { $warn = shift };
-
- my @created = remove_tree(
- $dir,
- $dir2,
- { foo => 1, bar => 1 }
- );
+ my $warn = _run_for_warning( sub {
+ my @created = remove_tree(
+ $dir,
+ $dir2,
+ { foo => 1, bar => 1 }
+ );
+ } );
like($warn,
qr/Unrecognized option\(s\) passed to
remove_tree\(\):.*?bar.*?foo/,
'remove_tree with final hashref failed due to unrecognized options'
@@ -656,7 +679,7 @@ is(
{
my ($x, $message, $object, $expect, $rv, $arg, $error);
my ($k, $v, $second_error, $third_error);
- local $! = 2;
+ local $! = ENOENT;
$x = $!;
$message = 'message in a bottle';
@@ -729,3 +752,186 @@ is(
is($k, '', "key of hash is empty string, since 3rd arg was undef");
is($v, $expect, "value of hash is 2nd arg: $message");
}
+
+{
+ # https://rt.cpan.org/Ticket/Display.html?id=117019
+ # remove_tree(): Permit re-use of options hash without issuing a warning
+
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| ZoYhvc6RmGnl S2CrQ0lju0o7 lvOqVYWpfhcP | );
+ my @created;
+ @created = File::Path::make_path($deepest, { mode => 0711 });
+ is(scalar(@created), 3, "Created 3 subdirectories");
+
+ my $x = '';
+ my $opts = { error => \$x };
+ File::Path::remove_tree($deepest, $opts);
+ ok(! -d $deepest, "directory '$deepest' removed, as expected");
+
+ my $warn;
+ $warn = _run_for_warning( sub { File::Path::remove_tree($next_deepest,
$opts); } );
+ ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts");
+ ok(! -d $next_deepest, "directory '$next_deepest' removed, as expected");
+
+ $warn = _run_for_warning( sub { File::Path::remove_tree($least_deep,
$opts); } );
+ ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts");
+ ok(! -d $least_deep, "directory '$least_deep' removed, as expected");
+}
+
+{
+ # Corner cases with respect to arguments provided to functions
+ my $count;
+
+ $count = remove_tree();
+ is($count, 0,
+ "If not provided with any paths, remove_tree() will return a count of
0 things deleted");
+
+ $count = remove_tree('');
+ is($count, 0,
+ "If not provided with any paths, remove_tree() will return a count of
0 things deleted");
+
+ my $warn;
+ $warn = _run_for_warning( sub { $count = rmtree(); } );
+ like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
+ is($count, 0,
+ "If not provided with any paths, remove_tree() will return a count of
0 things deleted");
+
+ $warn = _run_for_warning( sub {$count = rmtree(undef); } );
+ like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
+ is($count, 0,
+ "If provided only with an undefined value, remove_tree() will return a
count of 0 things deleted");
+
+ $warn = _run_for_warning( sub {$count = rmtree(''); } );
+ like($warn, qr/No root path\(s\) specified/s, "Got expected carp");
+ is($count, 0,
+ "If provided with an empty string for a path, remove_tree() will
return a count of 0 things deleted");
+
+ $count = make_path();
+ is($count, 0,
+ "If not provided with any paths, make_path() will return a count of 0
things created");
+
+ $count = mkpath();
+ is($count, 0,
+ "If not provided with any paths, make_path() will return a count of 0
things created");
+}
+
+SKIP: {
+ my $skip_count = 5;
+ skip "Windows will not set this error condition", $skip_count
+ if $^O eq 'MSWin32';
+
+ # mkpath() with hashref: case of phony user
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| Hhu1KpF4EVAV vUj5k37bih8v Vkdw02POXJxj | );
+ my (@created, $error);
+ my $user = join('_' => 'foobar', $$);
+ @created = mkpath($deepest, { mode => 0711, user => $user, error =>
\$error });
+ TODO: {
+ local $TODO = "Notwithstanding the phony 'user', mkpath will actually
create subdirectories; should it?";
+ is(scalar(@created), 0, "No subdirectories created");
+ }
+ is(scalar(@$error), 1, "caught error condition" );
+ my ($file, $message) = each %{$error->[0]};
+ like($message,
+ qr/unable to map $user to a uid, ownership not changed/s,
+ "Got expected error message for phony user",
+ );
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+{
+ # mkpath() with hashref: case of valid uid
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| b5wj8CJcc7gl XTJe2C3WGLg5 VZ_y2T0XfKu3 | );
+ my (@created, $error);
+ @created = mkpath($deepest, { mode => 0711, uid => $>, error => \$error });
+ is(scalar(@created), 3, "Provide valid 'uid' argument: 3 subdirectories
created");
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+SKIP: {
+ my $skip_count = 3;
+ skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
+ if $^O eq 'MSWin32';
+
+ # mkpath() with hashref: case of valid owner
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| aiJEDKaAEH25 nqhXsBM_7_bv qfRj4cur4Jrs | );
+ my (@created, $error);
+ my $name = getpwuid($>);
+ @created = mkpath($deepest, { mode => 0711, owner => $name, error =>
\$error });
+ is(scalar(@created), 3, "Provide valid 'owner' argument: 3 subdirectories
created");
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+SKIP: {
+ my $skip_count = 5;
+ skip "Windows will not set this error condition", $skip_count
+ if $^O eq 'MSWin32';
+
+ # mkpath() with hashref: case of phony group
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| nOR4lGRMdLvz NnwkEHEVL5li _3f1Kv6q77yA | );
+ my (@created, $error);
+ my $bad_group = join('_' => 'foobarbaz', $$);
+ @created = mkpath($deepest, { mode => 0711, group => $bad_group, error =>
\$error });
+ TODO: {
+ local $TODO = "Notwithstanding the phony 'group', mkpath will actually
create subdirectories; should it?";
+ is(scalar(@created), 0, "No subdirectories created");
+ }
+ is(scalar(@$error), 1, "caught error condition" );
+ my ($file, $message) = each %{$error->[0]};
+ like($message,
+ qr/unable to map $bad_group to a gid, group ownership not changed/s,
+ "Got expected error message for phony user",
+ );
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+{
+ # mkpath() with hashref: case of valid group
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| BEcigvaBNisY rd4lJ1iZRyeS OyQnDPIBxP2K | );
+ my (@created, $error);
+ @created = mkpath($deepest, { mode => 0711, group => $(, error => \$error
});
+ is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories
created");
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+SKIP: {
+ my $skip_count = 3;
+ skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
+ if $^O eq 'MSWin32';
+
+ # mkpath() with hashref: case of valid group
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| IayhWFDvys8X gTd6gaeuFzmV VVI6UWLJCOEC | );
+ my (@created, $error);
+ my $group_name = (getgrgid($())[0];
+ @created = mkpath($deepest, { mode => 0711, group => $group_name, error =>
\$error });
+ is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories
created");
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
+SKIP: {
+ my $skip_count = 3;
+ skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count
+ if $^O eq 'MSWin32';
+
+ # mkpath() with hashref: case of valid owner and group
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| xsmOvlnxOqJc olsGlBSoVUpp tDuRilkD35rd | );
+ my (@created, $error);
+ my $name = getpwuid($>);
+ my $group_name = (getgrgid($())[0];
+ @created = mkpath($deepest, { mode => 0711, owner => $name, group =>
$group_name, error => \$error });
+ is(scalar(@created), 3, "Provide valid 'owner' and 'group' 'group'
arguments: 3 subdirectories created");
+
+ cleanup_3_level_subdirs($least_deep);
+}
diff --git a/cpan/File-Path/t/Path_root.t b/cpan/File-Path/t/Path_root.t
index 36aeb1677d..2647b7fd12 100644
--- a/cpan/File-Path/t/Path_root.t
+++ b/cpan/File-Path/t/Path_root.t
@@ -1,15 +1,17 @@
use strict;
use Test::More;
use Config;
-use lib 't/';
-use FilePathTest;
+use lib './t';
+use FilePathTest qw(
+ _run_for_warning
+);
use File::Path qw(rmtree mkpath make_path remove_tree);
use File::Spec::Functions;
my $prereq = prereq();
plan skip_all => $prereq if defined $prereq;
-plan tests => 8;
+plan tests => 11;
my $pwent = max_u();
my $grent = max_g();
@@ -60,21 +62,35 @@ is(scalar(@created), 1, "created a directory owned by
$max_user:$max_group...");
is($dir_uid, $max_uid, "... owned by $max_uid");
is($dir_gid, $max_gid, "... owned by group $max_gid");
-SKIP: {
- skip('Skip until RT 85878 is fixed', 1);
+{
# invent a user and group that don't exist
do { ++$max_user } while ( getpwnam( $max_user ) );
do { ++$max_group } while ( getgrnam( $max_group ) );
$dir = catdir($dir_stem, 'aad');
- my $rv = _run_for_warning( sub { make_path( $dir,
- { user => $max_user,
- group => $max_group } ) } );
+ my $rv = _run_for_warning( sub {
+ make_path(
+ $dir,
+ { user => $max_user, group => $max_group }
+ )
+ } );
+ like( $rv,
+ qr{unable to map $max_user to a uid, ownership not changed:}s,
+ "created a directory not owned by $max_user:$max_group...",
+ );
like( $rv,
- qr{\Aunable to map $max_user to a uid, ownership not changed: .* at
\S+ line \d+
-unable to map $max_group to a gid, group ownership not changed: .* at \S+ line
\d+\b},
- "created a directory not owned by $max_user:$max_group..."
- );
+ qr{unable to map $max_group to a gid, group ownership not changed:}s,
+ "created a directory not owned by $max_user:$max_group...",
+ );
+}
+
+{
+ # cleanup
+ my $x;
+ my $opts = { error => \$x };
+ remove_tree($tmp_base, $opts);
+ ok(! -d $tmp_base, "directory '$tmp_base' removed, as expected");
+ is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts");
}
sub max_u {
diff --git a/cpan/File-Path/t/Path_win32.t b/cpan/File-Path/t/Path_win32.t
index 47168822b9..2638f99622 100644
--- a/cpan/File-Path/t/Path_win32.t
+++ b/cpan/File-Path/t/Path_win32.t
@@ -1,16 +1,20 @@
use strict;
use Test::More;
-use lib 't/';
-use FilePathTest;
+use lib './t';
+use FilePathTest qw(
+ create_3_level_subdirs
+ cleanup_3_level_subdirs
+);
use File::Path;
use Cwd;
use File::Spec::Functions;
+use Carp;
plan skip_all => 'not win32' unless $^O eq 'MSWin32';
my ($ignore, $major, $minor, $build, $id) = Win32::GetOSVersion();
plan skip_all => "WinXP or later"
unless $id >= 2 && ($major > 5 || $major == 5 && $minor >= 1);
-plan tests => 3;
+plan tests => 9;
my $tmp_base = catdir(
curdir(),
@@ -30,3 +34,29 @@ ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir');
my $removed = rmtree($UNC_path);
cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
+
+{
+ my ($least_deep, $next_deepest, $deepest) =
+ create_3_level_subdirs( qw| IsVFFJfJ03Rk jD7ToWQFmcjm hMZR6S1qNSf5 | );
+ my (@created, $error);
+ my $user = join('_' => 'foobar', $$);
+ {
+ my $warn;
+ $SIG{__WARN__} = sub { $warn = shift };
+
+ @created = mkpath($deepest, { mode => 0711, user => $user, error =>
\$error });
+ like($warn,
+ qr/Option\(s\) implausible on Win32 passed to mkpath\(\) or
make_path\(\)/,
+ 'make_path with final hashref warned due to options implausible on
Win32'
+ );
+ TODO: {
+ local $TODO = "Notwithstanding the Win32-implausible 'user',
mkpath will actually create subdirectories; should it?";
+ is(scalar(@created), 0, "No subdirectories created");
+ }
+ is(scalar(@created), 3, "3 subdirectories created");
+ is(scalar(@$error), 0, "no error condition" );
+ }
+
+ cleanup_3_level_subdirs($least_deep);
+}
+
diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index c0e25a22fb..bef7e4a875 100644
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
@@ -18,7 +18,7 @@ BEGIN {
$HAVE_MONOTONIC
];
- $VERSION = '0.96';
+ $VERSION = '0.98';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
@@ -242,7 +242,7 @@ sub can_run {
} else {
for my $dir (
File::Spec->path,
- File::Spec->curdir
+ ( IS_WIN32 ? File::Spec->curdir : () )
) {
next if ! $dir || ! -d $dir;
my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName(
$dir ) : $dir, $command);
@@ -742,6 +742,29 @@ STDOUT from the executing program.
Coderef of a subroutine to call when a portion of data is received on
STDERR from the executing program.
+=item C<wait_loop_callback>
+
+Coderef of a subroutine to call inside of the main waiting loop
+(while C<run_forked> waits for the external to finish or fail).
+It is useful to stop running external process before it ends
+by itself, e.g.
+
+ my $r = run_forked("some external command", {
+ 'wait_loop_callback' => sub {
+ if (condition) {
+ kill(1, $$);
+ }
+ },
+ 'terminate_on_signal' => 'HUP',
+ });
+
+Combined with C<stdout_handler> and C<stderr_handler> allows terminating
+external command based on its output. Could also be used as a timer
+without engaging with L<alarm> (signals).
+
+Remember that this code could be called every millisecond (depending
+on the output which external command generates), so try to make it
+as lightweight as possible.
=item C<discard_output>
@@ -1075,6 +1098,10 @@ sub run_forked {
push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
}
+ if ($opts->{'wait_loop_callback'} &&
ref($opts->{'wait_loop_callback'}) eq 'CODE') {
+ $opts->{'wait_loop_callback'}->();
+ }
+
Time::HiRes::usleep(1);
}
diff --git a/cpan/JSON-PP/bin/json_pp b/cpan/JSON-PP/bin/json_pp
index 39bed4d7cf..1bde07c64e 100644
--- a/cpan/JSON-PP/bin/json_pp
+++ b/cpan/JSON-PP/bin/json_pp
@@ -6,8 +6,6 @@ use Getopt::Long;
use JSON::PP ();
-my $VERSION = '1.00';
-
# imported from JSON-XS/bin/json_xs
my %allow_json_opt = map { $_ => 1 } qw(
@@ -22,11 +20,11 @@ GetOptions(
't=s' => \( my $opt_to = 'json' ),
'json_opt=s' => \( my $json_opt = 'pretty' ),
'V' => \( my $version ),
-) or die "Usage: $0 [-v] -f from_format [-t to_format]\n";
+) or die "Usage: $0 [-V] [-f from_format] [-t to_format] [-json_opt
options]\n";
if ( $version ) {
- print "$VERSION\n";
+ print "$JSON::PP::VERSION\n";
exit;
}
@@ -58,6 +56,11 @@ my %T = (
},
'dumper' => sub {
require Data::Dumper;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
Data::Dumper::Dumper($_)
},
);
diff --git a/cpan/JSON-PP/lib/JSON/PP.pm b/cpan/JSON-PP/lib/JSON/PP.pm
index 9337ce9a76..fb07ceeb4b 100644
--- a/cpan/JSON-PP/lib/JSON/PP.pm
+++ b/cpan/JSON-PP/lib/JSON/PP.pm
@@ -4,14 +4,17 @@ package 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.27400_02';
+$JSON::PP::VERSION = '2.94';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -41,6 +44,13 @@ use constant P_AS_NONBLESSED => 17;
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(
@@ -54,31 +64,31 @@ BEGIN {
# 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 : '';
}
/;
}
@@ -89,16 +99,6 @@ BEGIN {
# 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
@@ -129,9 +129,6 @@ sub new {
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,
};
@@ -164,7 +161,7 @@ sub pretty {
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);
@@ -196,14 +193,24 @@ sub get_max_size { $_[0]->{max_size}; }
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];
@@ -229,7 +236,8 @@ sub sort_by {
}
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;
}
###############################
@@ -269,11 +277,11 @@ sub allow_bigint {
$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/};
@@ -287,7 +295,7 @@ sub allow_bigint {
}
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);
@@ -297,7 +305,7 @@ sub allow_bigint {
utf8::upgrade($str);
}
- if ($idx->[ P_SHRINK ]) {
+ if ($props->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
@@ -335,13 +343,14 @@ sub allow_bigint {
}
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);
@@ -365,15 +374,16 @@ sub allow_bigint {
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 . '}';
}
@@ -387,36 +397,53 @@ sub allow_bigint {
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");
}
@@ -428,25 +455,19 @@ sub allow_bigint {
: 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");
- }
**** PATCH TRUNCATED AT 2000 LINES -- 2655 NOT SHOWN ****
--
Perl5 Master Repository
