2 files changed, 107 insertions, 1 deletions

diff --git a/lib/ExtUtils/t/Install.t b/lib/ExtUtils/t/Install.t
index ae8d781104..f9e76668d9 100644
--- a/lib/ExtUtils/t/Install.t
+++ b/lib/ExtUtils/t/Install.t
@@ -17,7 +17,7 @@ use TieOut;
 use File::Path;
 use File::Spec;
 
-use Test::More tests => 38;
+use Test::More tests => 52;
 
 use MakeMaker::Test::Setup::BFD;
 
@@ -122,6 +122,56 @@ close DUMMY;
                                              '  UNINST=0 left different' );
 }
 
+# Test UNINST=1 only warning when failing to remove an irrelevent shadow file
+{
+  my $tfile='install-test/lib/perl/Big/Dummy.pm';
+  local $ExtUtils::Install::Testing = $tfile; 
+  local @INC = ('install-test/other_lib/perl','install-test/lib/perl');
+  local $ENV{PERL5LIB} = '';
+  ok( -r $tfile, 'different install exists' );
+  my @warn;
+  local $SIG{__WARN__}=sub { push @warn, @_; return };
+  my $ok=eval {
+    install( { 'blib/lib' => 'install-test/other_lib/perl',
+           read   => 'install-test/packlist',
+           write  => 'install-test/packlist'
+         },
+       0, 0, 1);
+    1
+  };
+  ok($ok,'  we didnt die');
+  ok(0+@warn,"  we did warn");
+  ok( -d 'install-test/other_lib/perl',        'install made other dir' );
+  ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', '  .pm file installed' );
+  ok( -r 'install-test/packlist',              '  packlist exists' );
+  ok( -r $tfile, '  UNINST=1 failed to remove different' );
+  
+}
+
+# Test UNINST=1 dieing when failing to remove an relevent shadow file
+{
+  my $tfile='install-test/lib/perl/Big/Dummy.pm';
+  local $ExtUtils::Install::Testing = $tfile;
+  local @INC = ('install-test/lib/perl','install-test/other_lib/perl');
+  local $ENV{PERL5LIB} = '';
+  ok( -r $tfile, 'different install exists' );
+  my @warn;
+  local $SIG{__WARN__}=sub { push @warn,@_; return };
+  my $ok=eval {
+    install( { 'blib/lib' => 'install-test/other_lib/perl',
+           read   => 'install-test/packlist',
+           write  => 'install-test/packlist'
+         },
+       0, 0, 1);
+    1
+  };
+  ok(!$ok,'  we did die');
+  ok(!@warn,"  we didnt warn");
+  ok( -d 'install-test/other_lib/perl',        'install made other dir' );
+  ok( -r 'install-test/other_lib/perl/Big/Dummy.pm', '  .pm file installed' );
+  ok( -r 'install-test/packlist',              '  packlist exists' );
+  ok( -r $tfile,'  UNINST=1 failed to remove different' );
+}
 
 # Test UNINST=1 removing other versions in other dirs.
 {
@@ -138,3 +188,4 @@ close DUMMY;
   ok( !-r 'install-test/lib/perl/Big/Dummy.pm',
                                              '  UNINST=1 removed different' );
 }
+
diff --git a/lib/ExtUtils/t/can_write_dir.t b/lib/ExtUtils/t/can_write_dir.t
new file mode 100755
index 0000000000..4d4df0bb88
--- /dev/null
+++ b/lib/ExtUtils/t/can_write_dir.t
@@ -0,0 +1,55 @@
+#!/usr/bin/perl -w
+
+# Test the private _can_write_dir() function.
+
+use strict;
+use ExtUtils::Install;
+use File::Spec;
+{ package FS;  our @ISA = qw(File::Spec); }
+
+# Alias it for easier access
+*can_write_dir = \&ExtUtils::Install::_can_write_dir;
+
+use Test::More 'no_plan';
+
+
+my $dne = FS->catdir(qw(does not exist));
+ok ! -e $dne;
+is_deeply [can_write_dir($dne)],
+          [1,
+           FS->curdir,
+           FS->catdir('does'),
+           FS->catdir('does', 'not'),
+           FS->catdir('does', 'not', 'exist')
+          ];
+
+
+my $abs_dne = FS->rel2abs($dne);
+ok ! -e $abs_dne;
+is_deeply [can_write_dir($abs_dne)],
+          [1,
+           FS->rel2abs(FS->curdir),
+           FS->rel2abs(FS->catdir('does')),
+           FS->rel2abs(FS->catdir('does', 'not')),
+           FS->rel2abs(FS->catdir('does', 'not', 'exist')),
+          ];
+
+
+my $exists = FS->catdir(qw(exists));
+my $subdir = FS->catdir(qw(exists subdir));
+ok mkdir $exists;
+END { rmdir $exists }
+
+ok chmod 0555, $exists, 'make read only';
+ok !-w $exists;
+is_deeply [can_write_dir($exists)], [0, $exists];
+is_deeply [can_write_dir($subdir)], [0, $exists, $subdir];
+
+ok chmod 0777, $exists, 'make writable';
+ok -w $exists;
+is_deeply [can_write_dir($exists)], [1, $exists];
+is_deeply [can_write_dir($subdir)],
+          [1,
+           $exists,
+           $subdir
+          ];