From: Slaven Rezic <slaven@rezic.de>
Date: Sun, 19 Oct 2003 19:11:31 +0000 (+0200)
Subject: Re: [perl #24245] File::Copy::copy damages hard linked files
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ac7b122df953c27d4beccf03efed78ec25b8f64d;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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;
+  }
+
 }