This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update File-Path to CPAN version 2.14
authorChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Wed, 14 Jun 2017 19:29:55 +0000 (20:29 +0100)
committerChris 'BinGOs' Williams <chris@bingosnet.co.uk>
Wed, 14 Jun 2017 19:29:55 +0000 (20:29 +0100)
  [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).

Porting/Maintainers.pl
cpan/File-Path/lib/File/Path.pm
cpan/File-Path/t/FilePathTest.pm
cpan/File-Path/t/Path.t
cpan/File-Path/t/Path_root.t
cpan/File-Path/t/Path_win32.t
t/porting/customized.dat

index 726e065..06b54ce 100755 (executable)
@@ -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' => {
index 034da1e..2b765e1 100644 (file)
@@ -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<jkeenan@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<bulkdd@cpan.org>>
 
+=item Charlie Gonzalez <F<itcharlie@cpan.org>>
+
 =item Craig A. Berry <F<craigberry@mac.com>>
 
+=item James E Keenan <F<jkeenan@cpan.org>>
+
+=item John Lightsey <F<john@perlsec.org>>
+
+=item Nigel Horne <F<njh@bandsman.co.uk>>
+
 =item Richard Elberger <F<riche@cpan.org>>
 
 =item Ryan Yee <F<ryee@cpan.org>>
@@ -1157,12 +1268,14 @@ Contributors to File::Path, in alphabetical order.
 
 =item Tom Lutz <F<tommylutz@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
 
index f9e8289..88b411d 100644 (file)
@@ -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;
index 5644f57..7eb8572 100644 (file)
@@ -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,
-      0);
+      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);
+}
index 36aeb16..2647b7f 100644 (file)
@@ -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 {
index 4716882..2638f99 100644 (file)
@@ -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);
+}
+
index 4f247c5..620b7a4 100644 (file)
@@ -1,8 +1,6 @@
 Digest cpan/Digest/Digest.pm 43f7f544cb11842b2f55c73e28930da50774e081
 Encode cpan/Encode/Unicode/Unicode.pm 9749692c67f7d69083034de9184a93f070ab4799
 ExtUtils::Constant cpan/ExtUtils-Constant/t/Constant.t a0369c919e216fb02767a637666bb4577ad79b02
-File::Path cpan/File-Path/lib/File/Path.pm fd8ce4420a0c113d3f47dd3223859743655c1da8
-File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683e
 JSON::PP cpan/JSON-PP/bin/json_pp a7b8de6c201ef177ee82624ee4ca6a47cc1a3b4f
 JSON::PP cpan/JSON-PP/lib/JSON/PP.pm 86f697dae482106270fdd659b18c95a54af764ba
 JSON::PP cpan/JSON-PP/t/011_pc_expo.t e4c896d5f06ca380ddb6b4d6cd5714ea3003ada6