This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade File::Path from version 2.11 to 2.12
authorSteve Hay <steve.m.hay@googlemail.com>
Tue, 13 Oct 2015 13:15:49 +0000 (14:15 +0100)
committerSteve Hay <steve.m.hay@googlemail.com>
Tue, 13 Oct 2015 13:15:49 +0000 (14:15 +0100)
MANIFEST
Porting/Maintainers.pl
cpan/File-Path/lib/File/Path.pm
cpan/File-Path/t/FilePathTest.pm [new file with mode: 0644]
cpan/File-Path/t/Path.t
cpan/File-Path/t/Path_root.t [new file with mode: 0644]
cpan/File-Path/t/Path_win32.t [new file with mode: 0644]

index 34c2e24..fdb316a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1147,7 +1147,10 @@ cpan/File-Fetch/lib/File/Fetch.pm        File::Fetch
 cpan/File-Fetch/t/01_File-Fetch.t      File::Fetch tests
 cpan/File-Fetch/t/null_subclass.t
 cpan/File-Path/lib/File/Path.pm                Do things like 'mkdir -p' and 'rm -r'
+cpan/File-Path/t/FilePathTest.pm       See if File::Path works
+cpan/File-Path/t/Path_root.t           See if File::Path works
 cpan/File-Path/t/Path.t                        See if File::Path works
+cpan/File-Path/t/Path_win32.t          See if File::Path works
 cpan/File-Path/t/taint.t               See if File::Path works with -T
 cpan/File-Temp/lib/File/Temp.pm        create safe temporary files and file handles
 cpan/File-Temp/t/cmp.t         See if File::Temp works
index e27d483..d3d3a50 100755 (executable)
@@ -502,12 +502,11 @@ use File::Glob qw(:case);
     },
 
     'File::Path' => {
-        'DISTRIBUTION' => 'RICHE/File-Path-2.11.tar.gz',
+        'DISTRIBUTION' => 'RICHE/File-Path-2.12.tar.gz',
         'FILES'        => q[cpan/File-Path],
         'EXCLUDED'     => [
-            qw( eg/setup-extra-tests
-                t/Path-Class.t
-                )
+            qw(t/Path-Class.t),
+            qr{^xt/},
         ],
     },
 
index 3ee17bc..36f12cc 100644 (file)
@@ -18,7 +18,7 @@ BEGIN {
 
 use Exporter ();
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION   = '2.11';
+$VERSION   = '2.12';
 $VERSION   = eval $VERSION;
 @ISA       = qw(Exporter);
 @EXPORT    = qw(mkpath rmtree);
@@ -344,7 +344,7 @@ sub _rmtree {
           : $root;
 
         my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
-          or ( _error( $arg, "$root", $root ) and next ROOT_DIR );
+          or next ROOT_DIR;
 
         if ( -d _ ) {
             $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
@@ -576,8 +576,7 @@ File::Path - Create or remove directory trees
 
 =head1 VERSION
 
-This document describes version 2.09 of File::Path, released
-2013-01-17.
+This document describes version 2.12 of File::Path.
 
 =head1 SYNOPSIS
 
@@ -717,11 +716,14 @@ 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>.
+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.
 
 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.
+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.
 
@@ -802,9 +804,12 @@ remove_tree().
 
 =item B<NOTE:>
 
-The following error handling mechanism is considered
-experimental and is subject to change pending feedback from
-users.
+The following error handling mechanism is consistent throughout all
+code paths EXCEPT in cases where the ROOT node is nonexistent.  In
+version 2.11 the maintainers attempted to rectify this inconsistency
+but too many downstream modules encountered problems.  In such case,
+if you require root node evaluation or error checking prior to calling
+C<make_path> or C<remove_tree>, you should take additional precautions.
 
 =back
 
@@ -1142,6 +1147,8 @@ Contributors to File::Path, in alphabetical order.
 
 =item <F<bulkdd@cpan.org>>
 
+=item Craig A. Berry <F<craigberry@mac.com>>
+
 =item Richard Elberger <F<riche@cpan.org>>
 
 =item Ryan Yee <F<ryee@cpan.org>>
diff --git a/cpan/File-Path/t/FilePathTest.pm b/cpan/File-Path/t/FilePathTest.pm
new file mode 100644 (file)
index 0000000..f9e8289
--- /dev/null
@@ -0,0 +1,112 @@
+package FilePathTest;
+use strict;
+use warnings;
+use base 'Exporter';
+use SelectSaver;
+use Cwd;
+use File::Spec::Functions;
+
+our @EXPORT = qw(_run_for_warning _run_for_verbose _basedir
+                 _cannot_delete_safe_mode
+                 _verbose_expected);
+
+sub _basedir {
+  return catdir( curdir(),
+                 sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+  );
+
+}
+
+sub _run_for_warning {
+  my $coderef = shift;
+  my $warn = '';
+  local $SIG{__WARN__} = sub { $warn .= shift };
+  &$coderef;
+  return $warn;
+}
+
+sub _run_for_verbose {
+  my $coderef = shift;
+  my $stdout = '';
+  {
+    my $guard = SelectSaver->new(_ref_to_fh(\$stdout));
+    &$coderef;
+  }
+  return $stdout;
+}
+
+sub _ref_to_fh {
+  my $output = shift;
+  open my $fh, '>', $output;
+  return $fh;
+}
+
+# Whether a directory can be deleted without modifying permissions varies
+# by platform and by current privileges, so we really have to do the same
+# check the module does in safe mode to determine that.
+
+sub _cannot_delete_safe_mode {
+  my $path = shift;
+  return $^O eq 'VMS'
+         ? !&VMS::Filespec::candelete($path)
+         : !-w $path;
+}
+
+# What verbose mode reports depends on what it can do in safe mode.
+# Plus on VMS, mkpath may report what it's operating on in a
+# different format from the format of the path passed to it.
+
+sub _verbose_expected {
+  my ($function, $path, $safe_mode, $base) = @_;
+  my $expected;
+
+  if ($function =~ m/^(mkpath|make_path)$/) {
+    # On VMS, mkpath reports in Unix format.  Maddeningly, it
+    # reports the top-level directory without a trailing slash
+    # and everything else with.
+    if ($^O eq 'VMS') {
+      $path = VMS::Filespec::unixify($path);
+      $path =~ s/\/$// if defined $base && $base;
+    }
+    $expected = "mkdir $path\n";
+  }
+  elsif ($function =~ m/^(rmtree|remove_tree)$/) {
+    # N.B. Directories must still/already exist for this to work.
+    $expected = $safe_mode && _cannot_delete_safe_mode($path)
+              ? "skipped $path\n"
+              : "rmdir $path\n";
+  }
+  elsif ($function =~ m/^(unlink)$/) {
+    $expected = "unlink $path\n";
+    $expected =~ s/\n\z/\.\n/ if $^O eq 'VMS';
+  }
+  else {
+    die "Unknown function $function in _verbose_expected";
+  }
+  return $expected;
+}
+
+BEGIN {
+  if ($] < 5.008000) {
+    eval qq{#line @{[__LINE__+1]} "@{[__FILE__]}"\n} . <<'END' or die $@;
+      no warnings 'redefine';
+      use Symbol ();
+
+      sub _ref_to_fh {
+        my $output = shift;
+        my $fh = Symbol::gensym();
+        tie *$fh, 'StringIO', $output;
+        return $fh;
+      }
+
+      package StringIO;
+      sub TIEHANDLE { bless [ $_[1] ], $_[0] }
+      sub CLOSE    { @{$_[0]} = (); 1 }
+      sub PRINT    { ${ $_[0][0] } .= $_[1] }
+      sub PRINTF   { ${ $_[0][0] } .= sprintf $_[1], @_[2..$#_] }
+      1;
+END
+  }
+}
+
+1;
index ea4d2b5..5644f57 100644 (file)
@@ -3,22 +3,18 @@
 
 use strict;
 
-use Test::More tests => 159;
+use Test::More tests => 127;
 use Config;
 use Fcntl ':mode';
+use lib 't/';
+use FilePathTest;
 
 BEGIN {
-    # 1
     use_ok('Cwd');
-    # 2
     use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
-    # 3
     use_ok('File::Spec::Functions');
 }
 
-eval "use Test::Output";
-my $has_Test_Output = $@ ? 0 : 1;
-
 my $Is_VMS = $^O eq 'VMS';
 
 # first check for stupid permissions second for full, so we clean up
@@ -29,13 +25,12 @@ for my $perm (0111,0777) {
     chmod $perm, "mhx", $path;
 
     my $oct = sprintf('0%o', $perm);
-    # 4
+
     ok(-d "mhx", "mkdir parent dir $oct");
-    # 5
     ok(-d $path, "mkdir child dir $oct");
 
     rmtree("mhx");
-    # 6
+
     ok(! -e "mhx", "mhx does not exist $oct");
 }
 
@@ -57,7 +52,6 @@ my @dir = (
 # create them
 my @created = mkpath([@dir]);
 
-# 7
 is(scalar(@created), 7, "created list of directories");
 
 # pray for no race conditions blowing them out from under us
@@ -81,12 +75,10 @@ SKIP: {
     skip "cannot remove a file we failed to create", 1
         unless $file_count == 1;
     my $count = rmtree($file_name);
-# 8
     is($count, 1, "rmtree'ed a file");
 }
 
 @created = mkpath('');
-# 9
 is(scalar(@created), 0, "Can't create a directory named ''");
 
 my $dir;
@@ -112,16 +104,14 @@ sub count {
     open my $f, '>', 'foo.dat';
     close $f;
     my $before = count(curdir());
-# 10
     cmp_ok($before, '>', 0, "baseline $before");
 
     gisle('1st', 1);
-# 11
     is(count(curdir()), $before + 1, "first after $before");
 
     $before = count(curdir());
     gisle('2nd', 1);
-# 12
+
     is(count(curdir()), $before + 1, "second after $before");
 
     chdir updir();
@@ -134,13 +124,13 @@ sub count {
     open my $f, '>', 'foo.dat';
     close $f;
     my $before = count(curdir());
-# 13
+
     cmp_ok($before, '>', 0, "ARGV $before");
     {
         local @ARGV = (1);
         mkpath('3rd', !shift, 0755);
     }
-# 14
+
     is(count(curdir()), $before + 1, "third after $before");
 
     $before = count(curdir());
@@ -148,7 +138,7 @@ sub count {
         local @ARGV = (1);
         mkpath('4th', !shift, 0755);
     }
-# 15
+
     is(count(curdir()), $before + 1, "fourth after $before");
 
     chdir updir();
@@ -169,21 +159,21 @@ SKIP: {
 
     rmtree($dir, {error => \$error});
     my $nr_err = @$error;
-# 16
+
     is($nr_err, 1, "ancestor error");
 
     if ($nr_err) {
         my ($file, $message) = each %{$error->[0]};
-# 17
+
         is($file, $dir, "ancestor named");
         my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
         $^O eq 'MSWin32' and $message
             =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
-# 18
+
         is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
-# 19
+
         ok(-d $dir2, "child not removed");
-# 20
+
         ok(-d $dir, "ancestor not removed");
     }
     else {
@@ -194,18 +184,18 @@ SKIP: {
     }
     chdir $cwd;
     rmtree($dir);
-# 21
+
     ok(!(-d $dir), "ancestor now removed");
 };
 
 my $count = rmtree({error => \$error});
-# 22
+
 is( $count, 0, 'rmtree of nothing, count of zero' );
-# 23
+
 is( scalar(@$error), 0, 'no diagnostic captured' );
 
 @created = mkpath($tmp_base, 0);
-# 24
+
 is(scalar(@created), 0, "skipped making existing directories (old style 1)")
     or diag("unexpectedly recreated @created");
 
@@ -213,13 +203,13 @@ $dir = catdir($tmp_base,'C');
 # mkpath returns unix syntax filespecs on VMS
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 @created = make_path($tmp_base, $dir);
-# 25
+
 is(scalar(@created), 1, "created directory (new style 1)");
-# 26
+
 is($created[0], $dir, "created directory (new style 1) cross-check");
 
 @created = mkpath($tmp_base, 0, 0700);
-# 27
+
 is(scalar(@created), 0, "skipped making existing directories (old style 2)")
     or diag("unexpectedly recreated @created");
 
@@ -227,34 +217,35 @@ $dir2 = catdir($tmp_base,'D');
 # mkpath returns unix syntax filespecs on VMS
 $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
 @created = make_path($tmp_base, $dir, $dir2);
-# 28
+
 is(scalar(@created), 1, "created directory (new style 2)");
-# 29
+
 is($created[0], $dir2, "created directory (new style 2) cross-check");
 
 $count = rmtree($dir, 0);
-# 30
+
 is($count, 1, "removed directory unsafe mode");
 
+my $expected_count = _cannot_delete_safe_mode($dir2) ? 0 : 1;
+
 $count = rmtree($dir2, 0, 1);
-my $removed = $Is_VMS ? 0 : 1;
-# 31
-is($count, $removed, "removed directory safe mode");
+
+is($count, $expected_count, "removed directory safe mode");
 
 # mkdir foo ./E/../Y
 # Y should exist
 # existence of E is neither here nor there
 $dir = catdir($tmp_base, 'E', updir(), 'Y');
 @created =mkpath($dir);
-# 32
+
 cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
-# 33
+
 cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
-# 34
+
 ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
 
 @created = make_path(catdir(curdir(), $tmp_base));
-# 35
+
 is(scalar(@created), 0, "nothing created")
     or diag(@created);
 
@@ -269,14 +260,14 @@ rmtree( $dir, $dir2,
     }
 );
 
-# 36
+
 is(scalar(@$error), 0, "no errors unlinking a and z");
-# 37
+
 is(scalar(@$list),  4, "list contains 4 elements")
     or diag("@$list");
-# 38
+
 ok(-d $dir,  "dir a still exists");
-# 39
+
 ok(-d $dir2, "dir z still exists");
 
 $dir = catdir($tmp_base,'F');
@@ -284,38 +275,38 @@ $dir = catdir($tmp_base,'F');
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 
 @created = mkpath($dir, undef, 0770);
-# 40
+
 is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
-# 41
+
 is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
-# 42
+
 is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
 
 @created = mkpath($dir, undef);
-# 43
+
 is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
-# 44
+
 is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
-# 45
+
 is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
 
 @created = mkpath($dir, 0, undef);
-# 46
+
 is(scalar(@created), 1, "created directory (old style 3 mode undef)");
-# 47
+
 is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
-# 48
+
 is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
 
 $dir = catdir($tmp_base,'G');
 $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
 
 @created = mkpath($dir, undef, 0200);
-# 49
+
 is(scalar(@created), 1, "created write-only dir");
-# 50
+
 is($created[0], $dir, "created write-only directory cross-check");
-# 51
+
 is(rmtree($dir), 1, "removed write-only dir");
 
 # borderline new-style heuristics
@@ -330,46 +321,44 @@ $dir   = catdir('a', 'd1');
 $dir2  = catdir('a', 'd2');
 
 @created = make_path( $dir, 0, $dir2 );
-# 52
+
 is(scalar @created, 3, 'new-style 3 dirs created');
 
 $count = remove_tree( $dir, 0, $dir2, );
-# 53
+
 is($count, 3, 'new-style 3 dirs removed');
 
 @created = make_path( $dir, $dir2, 1 );
-# 54
+
 is(scalar @created, 3, 'new-style 3 dirs created (redux)');
 
 $count = remove_tree( $dir, $dir2, 1 );
-# 55
+
 is($count, 3, 'new-style 3 dirs removed (redux)');
 
 @created = make_path( $dir, $dir2 );
-# 56
+
 is(scalar @created, 2, 'new-style 2 dirs created');
 
 $count = remove_tree( $dir, $dir2 );
-# 57
+
 is($count, 2, 'new-style 2 dirs removed');
 
 $dir = catdir("a\nb", 'd1');
 $dir2 = catdir("a\nb", 'd2');
 
-
-
 SKIP: {
   # Better to search for *nix derivatives?
   # Not sure what else doesn't support newline in paths
-  skip "This is a MSWin32 platform", 2
-    if $^O eq 'MSWin32';
+  skip "$^O doesn't allow newline in paths", 2
+    if $^O =~ m/^(MSWin32|VMS)$/;
 
   @created = make_path( $dir, $dir2 );
-# 58
+
   is(scalar @created, 3, 'new-style 3 dirs created in parent with newline');
 
   $count = remove_tree( $dir, $dir2 );
-# 59
+
   is($count, 2, 'new-style 2 dirs removed in parent with newline');
 }
 
@@ -381,25 +370,6 @@ else {
 }
 
 SKIP: {
-    skip "This is not a MSWin32 platform", 3
-        unless $^O eq 'MSWin32';
-
-    my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir');
-    #dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off
-    #firewalled, disabled, blocked, or no NICs are on and there the PC has no
-    #working TCPIP stack, \\?\ will always work
-    $UNC_path = '\\\\?\\'.$UNC_path;
-# 60
-    is(mkpath($UNC_path), 1, 'mkpath on Win32 UNC path returns made 1 dir');
-# 61
-    ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir');
-
-    my $removed = rmtree($UNC_path);
-# 62
-    cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
-}
-
-SKIP: {
     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
     skip "Don't need Force_Writeable semantics on $^O", 6
         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
@@ -407,10 +377,10 @@ SKIP: {
     $dir  = 'bug487319';
     $dir2 = 'bug487319-symlink';
     @created = make_path($dir, {mask => 0700});
-# 63
+
     is( scalar @created, 1, 'bug 487319 setup' );
     symlink($dir, $dir2);
-# 64
+
     ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
 
     chmod 0500, $dir;
@@ -418,7 +388,7 @@ SKIP: {
     remove_tree($dir2);
 
     my $mask = (stat $dir)[2];
-# 65
+
     is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
 
     # now try a file
@@ -427,19 +397,19 @@ SKIP: {
     my $file2 = 'bug487319-file-symlink';
     open my $out, '>', $file;
     close $out;
-# 66
+
     ok(-e $file, 'file exists');
 
     chmod 0500, $file;
     $mask_initial = (stat $file)[2];
 
     symlink($file, $file2);
-# 67
+
     ok(-e $file2, 'file2 exists');
     remove_tree($file2);
 
     $mask = (stat $file)[2];
-# 68
+
     is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
 
     remove_tree($dir);
@@ -468,53 +438,6 @@ SKIP: {
         or diag(@created);
 }
 
-my $extra =  catdir(curdir(), qw(EXTRA 1 a));
-
-SKIP: {
-    skip "extra scenarios not set up, see eg/setup-extra-tests", 14
-        unless -e $extra;
-    skip "Symlinks not available", 14 unless $Config{d_symlink};
-
-    my ($list, $err);
-    $dir = catdir( 'EXTRA', '1' );
-    rmtree( $dir, {result => \$list, error => \$err} );
-    is(scalar(@$list), 2, "extra dir $dir removed");
-    is(scalar(@$err), 1, "one error encountered");
-
-    $dir = catdir( 'EXTRA', '3', 'N' );
-    rmtree( $dir, {result => \$list, error => \$err} );
-    is( @$list, 1, q{remove a symlinked dir} );
-    is( @$err,  0, q{with no errors} );
-
-    $dir = catdir('EXTRA', '3', 'S');
-    rmtree($dir, {error => \$error});
-    is( scalar(@$error), 1, 'one error for an unreadable dir' );
-    eval { ($file, $message) = each %{$error->[0]}};
-    is( $file, $dir, 'unreadable dir reported in error' )
-        or diag($message);
-
-    $dir = catdir('EXTRA', '3', 'T');
-    rmtree($dir, {error => \$error});
-    is( scalar(@$error), 1, 'one error for an unreadable dir T' );
-    eval { ($file, $message) = each %{$error->[0]}};
-    is( $file, $dir, 'unreadable dir reported in error T' );
-
-    $dir = catdir( 'EXTRA', '4' );
-    rmtree($dir,  {result => \$list, error => \$err} );
-    is( scalar(@$list), 0, q{don't follow a symlinked dir} );
-    is( scalar(@$err),  2, q{two errors when removing a symlink in r/o dir} );
-    eval { ($file, $message) = each %{$err->[0]} };
-    is( $file, $dir, 'symlink reported in error' );
-
-    $dir  = catdir('EXTRA', '3', 'U');
-    $dir2 = catdir('EXTRA', '3', 'V');
-    rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
-    is( scalar(@$list),  1, q{deleted 1 out of 2 directories} );
-    is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
-    eval { ($file, $message) = each %{$err->[0]} };
-    is( $file, $dir, 'first dir reported in error' );
-}
-
 {
     $dir = catdir($tmp_base, 'ZZ');
     @created = mkpath($dir);
@@ -527,7 +450,9 @@ SKIP: {
 
 SKIP : {
     my $skip_count = 19;
-    #this test will fail on Windows, as per: http://perldoc.perl.org/perlport.html#chmod
+    # 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';
     my $mode;
@@ -544,6 +469,9 @@ SKIP : {
 
     foreach (@inputs) {
         $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);
         @created = mkpath($dir, {chmod => $input});
         $mode = (stat($dir))[2];
         $octal_mode = S_IMODE($mode);
@@ -553,267 +481,139 @@ SKIP : {
     }
 }
 
-SKIP: {
-    my $skip_count = 8; # DRY
-    skip "getpwent() not implemented on $^O", $skip_count
-        unless $Config{d_getpwent};
-    skip "getgrent() not implemented on $^O", $skip_count
-        unless $Config{d_getgrent};
-    skip 'not running as root', $skip_count
-        unless $< == 0;
-    skip "darwin's nobody and nogroup are -1", $skip_count
-        if $^O eq 'darwin';
-
-    my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
-
-    # find the highest uid ('nobody' or similar)
-    my $max_uid   = 0;
-    my $max_user = undef;
-    while (my @u = getpwent()) {
-        if ($max_uid < $u[2]) {
-            $max_uid  = $u[2];
-            $max_user = $u[0];
-        }
-    }
-    skip 'getpwent() appears to be insane', $skip_count
-        unless $max_uid > 0;
-
-    # find the highest gid ('nogroup' or similar)
-    my $max_gid   = 0;
-    my $max_group = undef;
-    while (my @g = getgrent()) {
-        if ($max_gid < $g[2]) {
-            $max_gid = $g[2];
-            $max_group = $g[0];
-        }
-    }
-    skip 'getgrent() appears to be insane', $skip_count
-        unless $max_gid > 0;
-
-    $dir = catdir($dir_stem, 'aaa');
-    @created = make_path($dir, {owner => $max_user});
-    is(scalar(@created), 2, "created a directory owned by $max_user...");
-    my $dir_uid = (stat $created[0])[4];
-    is($dir_uid, $max_uid, "... owned by $max_uid");
-
-    $dir = catdir($dir_stem, 'aab');
-    @created = make_path($dir, {group => $max_group});
-    is(scalar(@created), 1, "created a directory owned by group $max_group...");
-    my $dir_gid = (stat $created[0])[5];
-    is($dir_gid, $max_gid, "... owned by group $max_gid");
-
-    $dir = catdir($dir_stem, 'aac');
-    @created = make_path($dir, {user => $max_user, group => $max_group});
-    is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
-    ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
-    is($dir_uid, $max_uid, "... owned by $max_uid");
-    is($dir_gid, $max_gid, "... owned by group $max_gid");
-
-    SKIP: {
-        skip 'Test::Output not available', 1
-               unless $has_Test_Output;
-
-        # 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');
-        stderr_like(
-            sub {make_path($dir, {user => $max_user, group => $max_group})},
-            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..."
-        );
-    }
-}
+my $dir_base = catdir($tmp_base,'output');
+my $dir_a    = catdir($dir_base, 'A');
+my $dir_b    = catdir($dir_base, 'B');
 
-SKIP: {
-    skip 'Test::Output not available', 18
-        unless $has_Test_Output;
-
-    SKIP: {
-        $dir = catdir('EXTRA', '3');
-        skip "extra scenarios not set up, see eg/setup-extra-tests", 3
-            unless -e $dir;
-
-        $dir = catdir('EXTRA', '3', 'U');
-        stderr_like(
-            sub {rmtree($dir, {verbose => 0})},
-            qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
-            q(rmtree can't chdir into root dir)
-        );
+is(_run_for_verbose(sub {@created = mkpath($dir_a, 1)}),
+    _verbose_expected('mkpath', $dir_base, 0, 1)
+    . _verbose_expected('mkpath', $dir_a, 0),
+    'mkpath verbose (old style 1)'
+);
 
-        $dir = catdir('EXTRA', '3');
-        stderr_like(
-            sub {rmtree($dir, {})},
-            qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2},
-            'rmtree with file owned by root'
-        );
+is(_run_for_verbose(sub {@created = mkpath([$dir_b], 1)}),
+    _verbose_expected('mkpath', $dir_b, 0),
+    'mkpath verbose (old style 2)'
+);
 
-        stderr_like(
-            sub {rmtree('EXTRA', {})},
-            qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot unlink file for [^:]+: .* at \1 line \2
-cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2},
-            'rmtree with insufficient privileges'
-        );
-    }
+my $verbose_expected;
 
-    my $base = catdir($tmp_base,'output');
-    $dir  = catdir($base,'A');
-    $dir2 = catdir($base,'B');
+# Must determine expectations while directories still exist.
+$verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
+                  . _verbose_expected('rmtree', $dir_b, 1);
 
-    stderr_like(
-        sub { rmtree( undef, 1 ) },
-        qr/\ANo root path\(s\) specified\b/,
-        "rmtree of nothing carps sensibly"
-    );
+is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
+    $verbose_expected,
+    'rmtree verbose (old style)'
+);
 
-    stderr_like(
-        sub { rmtree( '', 1 ) },
-        qr/\ANo root path\(s\) specified\b/,
-        "rmtree of empty dir carps sensibly"
-    );
+# In case we didn't delete them in safe mode.
+rmtree($dir_a) if -d $dir_a;
+rmtree($dir_b) if -d $dir_b;
 
-    stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
-    stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );
-    stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" );
+is(_run_for_verbose(sub {@created = mkpath( $dir_a,
+                                            {verbose => 1, mask => 0750})}),
+    _verbose_expected('mkpath', $dir_a, 0),
+    'mkpath verbose (new style 1)'
+);
 
-    stdout_is(
-        sub {@created = mkpath($dir, 1)},
-        "mkdir $base\nmkdir $dir\n",
-        'mkpath verbose (old style 1)'
-    );
+is(_run_for_verbose(sub {@created = mkpath($dir_b, 1, 0771)}),
+    _verbose_expected('mkpath', $dir_b, 0),
+    'mkpath verbose (new style 2)'
+);
 
-    stdout_is(
-        sub {@created = mkpath([$dir2], 1)},
-        "mkdir $dir2\n",
-        'mkpath verbose (old style 2)'
-    );
+$verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
+                  . _verbose_expected('rmtree', $dir_b, 1);
 
-    stdout_is(
-        sub {$count = rmtree([$dir, $dir2], 1, 1)},
-        "rmdir $dir\nrmdir $dir2\n",
-        'rmtree verbose (old style)'
-    );
+is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}),
+    $verbose_expected,
+    'again: rmtree verbose (old style)'
+);
 
-    stdout_is(
-        sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
-        "mkdir $dir\n",
-        'mkpath verbose (new style 1)'
-    );
+rmtree($dir_a) if -d $dir_a;
+rmtree($dir_b) if -d $dir_b;
 
-    stdout_is(
-        sub {@created = mkpath($dir2, 1, 0771)},
-        "mkdir $dir2\n",
-        'mkpath verbose (new style 2)'
-    );
+is(_run_for_verbose(sub {@created = make_path( $dir_a, $dir_b,
+                                               {verbose => 1, mode => 0711});}),
+      _verbose_expected('make_path', $dir_a, 1)
+    . _verbose_expected('make_path', $dir_b, 1),
+    'make_path verbose with final hashref'
+);
 
-    stdout_is(
-        sub {$count = rmtree([$dir, $dir2], 1, 1)},
-        "rmdir $dir\nrmdir $dir2\n",
-        'again: rmtree verbose (old style)'
-    );
+$verbose_expected = _verbose_expected('remove_tree', $dir_a, 0)
+                  . _verbose_expected('remove_tree', $dir_b, 0);
 
-    stdout_is(
-        sub {
-            @created = make_path(
-                $dir,
-                $dir2,
-                { verbose => 1, mode => 0711 }
-            );
-        },
-        "mkdir $dir\nmkdir $dir2\n",
-        'make_path verbose with final hashref'
-    );
+is(_run_for_verbose(sub {@created = remove_tree( $dir_a, $dir_b,
+                                                 {verbose => 1});}),
+    $verbose_expected,
+    'remove_tree verbose with final hashref'
+);
+
+rmtree($dir_a) if -d $dir_a;
+rmtree($dir_b) if -d $dir_b;
+
+# Have to re-create these 2 directories so that next block is not skipped.
+@created = make_path(
+    $dir_a,
+    $dir_b,
+    { mode => 0711 }
+);
+is(@created, 2, "2 directories created");
+
+SKIP: {
+    $file = catfile($dir_b, "file");
+    skip "Cannot create $file", 2 unless open OUT, "> $file";
+    print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+    close OUT;
+
+    $verbose_expected = _verbose_expected('rmtree', $dir_a, 1)
+                      . _verbose_expected('unlink', $file, 0)
+                      . _verbose_expected('rmtree', $dir_b, 1);
+
+    ok(-e $file, "file created in directory");
 
-    # {
-    #     local $@;
-    #     eval {
-    #         @created = make_path(
-    #             $dir,
-    #             $dir2,
-    #             { verbose => 1, mode => 0711, foo => 1, bar => 1 }
-    #         );
-    #     };
-    #     like($@,
-    #         qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/,
-    #         'make_path with final hashref failed due to unrecognized options'
-    #     );
-    # }
-    #
-    # {
-    #     local $@;
-    #     eval {
-    #         @created = remove_tree(
-    #             $dir,
-    #             $dir2,
-    #             { verbose => 1, foo => 1, bar => 1 }
-    #         );
-    #     };
-    #     like($@,
-    #         qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/,
-    #         'remove_tree with final hashref failed due to unrecognized options'
-    #     );
-    # }
-
-    stdout_is(
-        sub {
-            @created = remove_tree(
-                $dir,
-                $dir2,
-                { verbose => 1 }
-            );
-        },
-        "rmdir $dir\nrmdir $dir2\n",
-        'remove_tree verbose with final hashref'
+    is(_run_for_verbose(sub {$count = rmtree( $dir_a, $dir_b,
+                                              {verbose => 1, safe => 1})}),
+        $verbose_expected,
+        'rmtree safe verbose (new style)'
     );
+    rmtree($dir_a) if -d $dir_a;
+    rmtree($dir_b) if -d $dir_b;
+}
 
-    SKIP: {
-        $file = catdir($dir2, "file");
-        skip "Cannot create $file", 2 unless open OUT, "> $file";
-        print OUT "test file, safe to delete\n", scalar(localtime), "\n";
-        close OUT;
+{
+    my $base = catdir( $tmp_base, 'output2');
+    my $dir  = catdir( $base, 'A');
+    my $dir2 = catdir( $base, 'B');
 
-        ok(-e $file, "file created in directory");
+    {
+        my $warn;
+        $SIG{__WARN__} = sub { $warn = shift };
 
-        stdout_is(
-            sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
-            "rmdir $dir\nunlink $file\nrmdir $dir2\n",
-            'rmtree safe verbose (new style)'
+        my @created = make_path(
+            $dir,
+            $dir2,
+            { mode => 0711, foo => 1, bar => 1 }
+        );
+        like($warn,
+            qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/,
+            'make_path with final hashref warned due to unrecognized options'
         );
     }
-}
 
-SKIP: {
-    skip "extra scenarios not set up, see eg/setup-extra-tests", 11
-        unless -d catdir(qw(EXTRA 1));
-
-    rmtree 'EXTRA', {safe => 0, error => \$error};
-    is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
-
-    rmtree 'EXTRA', {safe => 1, error => \$error};
-    is( scalar(@$error), 9, 'safe is better' );
-    for (@$error) {
-        ($file, $message) = each %$_;
-        if ($file =~  /[123]\z/) {
-            is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
-                or diag($message);
-        }
-        else {
-            like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
-                or diag($message)
-        }
+    {
+        my $warn;
+        $SIG{__WARN__} = sub { $warn = shift };
+
+        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'
+        );
     }
 }
 
@@ -832,14 +632,17 @@ SKIP: {
     ok(mkpath($xx), "make $xx");
     ok(chdir($xx), "... and chdir $xx");
     END {
-         ok(chdir($p), "... now chdir $p");
-         ok(rmtree($xx), "... and finally rmtree $xx");
+#         ok(chdir($p), "... now chdir $p");
+#         ok(rmtree($xx), "... and finally rmtree $xx");
+       chdir($p);
+       rmtree($xx);
     }
 
     # create and delete directory
     my $px = catdir($p, $x);
     ok(mkpath($px), 'create and delete directory 2.07');
     ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
+    chdir updir();
 }
 
 my $windows_dir = 'C:\Path\To\Dir';
@@ -849,3 +652,80 @@ is(
     $expect,
     "Windows path unixified as expected"
 );
+
+{
+    my ($x, $message, $object, $expect, $rv, $arg, $error);
+    my ($k, $v, $second_error, $third_error);
+    local $! = 2;
+    $x = $!;
+
+    $message = 'message in a bottle';
+    $object = '/path/to/glory';
+    $expect = "$message for $object: $x";
+    $rv = _run_for_warning( sub {
+        File::Path::_error(
+            {},
+            $message,
+            $object
+        );
+    } );
+    like($rv, qr/^$expect/,
+        "no \$arg->{error}: defined 2nd and 3rd args: got expected error message");
+
+    $object = undef;
+    $expect = "$message: $x";
+    $rv = _run_for_warning( sub {
+        File::Path::_error(
+            {},
+            $message,
+            $object
+        );
+    } );
+    like($rv, qr/^$expect/,
+        "no \$arg->{error}: defined 2nd arg; undefined 3rd arg: got expected error message");
+
+    $message = 'message in a bottle';
+    $object = undef;
+    $expect = "$message: $x";
+    $arg = { error => \$error };
+    File::Path::_error(
+        $arg,
+        $message,
+        $object
+    );
+    is(ref($error->[0]), 'HASH',
+        "first element of array inside \$error is hashref");
+    ($k, $v) = %{$error->[0]};
+    is($k, '', 'key of hash is empty string, since 3rd arg was undef');
+    is($v, $expect, "value of hash is 2nd arg: $message");
+
+    $message = '';
+    $object = '/path/to/glory';
+    $expect = "$message: $x";
+    $arg = { error => \$second_error };
+    File::Path::_error(
+        $arg,
+        $message,
+        $object
+    );
+    is(ref($second_error->[0]), 'HASH',
+        "first element of array inside \$second_error is hashref");
+    ($k, $v) = %{$second_error->[0]};
+    is($k, $object, "key of hash is '$object', since 3rd arg was defined");
+    is($v, $expect, "value of hash is 2nd arg: $message");
+
+    $message = '';
+    $object = undef;
+    $expect = "$message: $x";
+    $arg = { error => \$third_error };
+    File::Path::_error(
+        $arg,
+        $message,
+        $object
+    );
+    is(ref($third_error->[0]), 'HASH',
+        "first element of array inside \$third_error is hashref");
+    ($k, $v) = %{$third_error->[0]};
+    is($k, '', "key of hash is empty string, since 3rd arg was undef");
+    is($v, $expect, "value of hash is 2nd arg: $message");
+}
diff --git a/cpan/File-Path/t/Path_root.t b/cpan/File-Path/t/Path_root.t
new file mode 100644 (file)
index 0000000..36aeb16
--- /dev/null
@@ -0,0 +1,123 @@
+use strict;
+use Test::More;
+use Config;
+use lib 't/';
+use FilePathTest;
+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;
+
+my $pwent = max_u();
+my $grent = max_g();
+my ( $max_uid, $max_user ) = @{ $pwent };
+my ( $max_gid, $max_group ) = @{ $grent };
+
+my $tmp_base = catdir(
+    curdir(),
+    sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+);
+
+# invent some names
+my @dir = (
+    catdir($tmp_base, qw(a b)),
+    catdir($tmp_base, qw(a c)),
+    catdir($tmp_base, qw(z b)),
+    catdir($tmp_base, qw(z c)),
+);
+
+# create them
+my @created = mkpath([@dir]);
+
+my $dir;
+my $dir2;
+
+my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
+
+$dir = catdir($dir_stem, 'aaa');
+@created = make_path($dir, {owner => $max_user});
+is(scalar(@created), 2, "created a directory owned by $max_user...");
+
+my $dir_uid = (stat $created[0])[4];
+is($dir_uid, $max_uid, "... owned by $max_uid");
+
+$dir = catdir($dir_stem, 'aab');
+@created = make_path($dir, {group => $max_group});
+is(scalar(@created), 1, "created a directory owned by group $max_group...");
+
+my $dir_gid = (stat $created[0])[5];
+is($dir_gid, $max_gid, "... owned by group $max_gid");
+
+$dir = catdir($dir_stem, 'aac');
+@created = make_path( $dir, { user => $max_user,
+                              group => $max_group});
+is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
+
+($dir_uid, $dir_gid) = (stat $created[0])[4,5];
+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 } ) } );
+  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..."
+      );
+}
+
+sub max_u {
+  # find the highest uid ('nobody' or similar)
+  my $max_uid   = 0;
+  my $max_user = undef;
+  while (my @u = getpwent()) {
+    if ($max_uid < $u[2]) {
+      $max_uid  = $u[2];
+      $max_user = $u[0];
+    }
+  }
+  setpwent(); # in case we want to run again later
+  return [ $max_uid, $max_user ];
+}
+
+sub max_g {
+  # find the highest gid ('nogroup' or similar)
+  my $max_gid   = 0;
+  my $max_group = undef;
+  while ( my @g = getgrent() ) {
+    print Dumper @g;
+    if ($max_gid < $g[2]) {
+      $max_gid = $g[2];
+      $max_group = $g[0];
+    }
+  }
+  setgrent(); # in case we want to run again later
+  return [ $max_gid, $max_group ];
+}
+
+sub prereq {
+  return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
+  return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
+  return "not running as root" unless $< == 0;
+  return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin';
+
+  my $pwent = max_u();
+  my $grent = max_g();
+  my ( $max_uid, $max_user ) = @{ $pwent };
+  my ( $max_gid, $max_group ) = @{ $grent };
+
+  return "getpwent() appears to be insane" unless $max_uid > 0;
+  return "getgrent() appears to be insane" unless $max_gid > 0;
+  return undef;
+}
diff --git a/cpan/File-Path/t/Path_win32.t b/cpan/File-Path/t/Path_win32.t
new file mode 100644 (file)
index 0000000..c2b2f28
--- /dev/null
@@ -0,0 +1,29 @@
+use strict;
+use Test::More;
+use lib 't/';
+use FilePathTest;
+use File::Path;
+use Cwd;
+use File::Spec::Functions;
+
+plan skip_all  => 'not win32' unless $^O eq 'MSWin32';
+plan tests     => 3;
+
+my $tmp_base = catdir(
+    curdir(),
+    sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+);
+
+my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir');
+#dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off
+#firewalled, disabled, blocked, or no NICs are on and there the PC has no
+#working TCPIP stack, \\?\ will always work
+$UNC_path = '\\\\?\\'.$UNC_path;
+
+is(mkpath($UNC_path), 2, 'mkpath on Win32 UNC path returns made 2 dir - base and uncdir');
+
+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");