Re: [perl #24245] File::Copy::copy damages hard linked files

Message-ID: <87smlprw3g.fsf@vran.herceg.de>
(with further tweaks)

p4raw-id: //depot/perl@21797

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index 0e87e98..a01192b 100644 (file)
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -24,7 +24,7 @@ sub mv;
 # package has not yet been updated to work with Perl 5.004, and so it
 # would be a Bad Thing for the CPAN module to grab it and replace this
 # module.  Therefore, we set this module's version higher than 2.0.
-$VERSION = '2.06';
+$VERSION = '2.07';
 
 require Exporter;
 @ISA = qw(Exporter);
@@ -77,13 +77,12 @@ sub copy {
        croak("'$from' and '$to' are identical (not copied)");
     }
 
-    if ($Config{d_symlink} && $Config{d_readlink} &&
+    if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
        !($^O eq 'Win32' || $^O eq 'os2' || $^O eq 'vms')) {
-       no warnings 'io'; # don't warn if -l on filehandle
-       if ((-e $from && -l $from) || (-e $to && -l $to)) {
-           my @fs = stat($from);
+       my @fs = stat($from);
+       if (@fs) {
            my @ts = stat($to);
-           if (@fs && @ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
+           if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
                croak("'$from' and '$to' are identical (not copied)");
            }
        }

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index 6f8c801..670f37c 100755 (executable)
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -9,10 +9,11 @@ BEGIN {
 $| = 1;
 
 my @pass = (0,1);
-my $tests = $^O eq 'MacOS' ? 15 : 12;
+my $tests = $^O eq 'MacOS' ? 17 : 14;
 printf "1..%d\n", $tests * scalar(@pass);
 
 use File::Copy;
+use Config;
 
 for my $pass (@pass) {
 
@@ -83,6 +84,7 @@ for my $pass (@pass) {
   print "# foo=`$foo'\nnot " unless $foo eq sprintf "ok %d\n", 3+$loopconst;
   printf "ok %d\n", 9+$loopconst;
 
+  my $test_i;
   if ($^O eq 'MacOS') {
        
     copy "file-$$", "lib";     
@@ -122,7 +124,8 @@ for my $pass (@pass) {
        unless $@ =~ /are identical/ && -s "copy-$$";
 
     unlink ":lib:file-$$" or die "unlink: $!";
-  
+
+    $test_i = 15;
   } else {
     
     copy "file-$$", "lib";
@@ -142,8 +145,38 @@ for my $pass (@pass) {
        unless $@ =~ /are identical/ && -s "copy-$$";
 
     unlink "lib/file-$$" or die "unlink: $!";
-  
+
+    $test_i = 12;
+  }
+
+  if ($Config{d_symlink}) {
+    open(F, ">file-$$") or die $!;
+    print F "dummy content\n";
+    close F;
+    symlink("file-$$", "symlink-$$") or die $!;
+    eval { copy("file-$$", "symlink-$$") };
+    print "not " if $@ !~ /are identical/ || -z "file-$$";
+    printf "ok %d\n", (++$test_i)+$loopconst;
+    unlink "symlink-$$";
+    unlink "file-$$";
+  } else {
+    printf "ok %d # Skipped: no symlinks on this platform\n", (++$test_i)+$loopconst;
   }
+
+  if ($Config{d_link}) {
+    open(F, ">file-$$") or die $!;
+    print F "dummy content\n";
+    close F;
+    link("file-$$", "hardlink-$$") or die $!;
+    eval { copy("file-$$", "hardlink-$$") };
+    print "not " if $@ !~ /are identical/ || -z "file-$$";
+    printf "ok %d\n", (++$test_i)+$loopconst;
+    unlink "hardlink-$$";
+    unlink "file-$$";
+  } else {
+    printf "ok %d # Skipped: no hardlinks on this platform\n", (++$test_i)+$loopconst;
+  }
+
 }