Re: [perl #36507] File::Copy::copy($foo, $foo) dies

Message-ID: <20050712225118.GA944@windhund.schwern.org>

(and update SKIP counts)

p4raw-id: //depot/perl@25143

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index 6316b97..57670e1 100644 (file)
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -37,6 +37,11 @@ sub croak {
     goto &Carp::croak;
 }
 
+sub carp {
+    require Carp;
+    goto &Carp::carp;
+}
+
 my $macfiles;
 if ($^O eq 'MacOS') {
        $macfiles = eval { require Mac::MoreFiles };
@@ -78,7 +83,10 @@ sub copy {
                         : (ref(\$to) eq 'GLOB'));
 
     if ($from eq $to) { # works for references, too
-       croak("'$from' and '$to' are identical (not copied)");
+       carp("'$from' and '$to' are identical (not copied)");
+        # The "copy" was a success as the source and destination contain
+        # the same data.
+        return 1;
     }
 
     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
@@ -87,7 +95,8 @@ sub copy {
        if (@fs) {
            my @ts = stat($to);
            if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
-               croak("'$from' and '$to' are identical (not copied)");
+               carp("'$from' and '$to' are identical (not copied)");
+                return 0;
            }
        }
     }
@@ -182,7 +191,10 @@ sub copy {
 }
 
 sub move {
+    croak("Usage: move(FROM, TO) ") unless @_ == 2;
+
     my($from,$to) = @_;
+
     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
 
     if (-d $to && ! -d $from) {
@@ -209,6 +221,7 @@ sub move {
     {
         local $@;
         eval {
+            local $SIG{__DIE__};
             copy($from,$to) or die;
             my($atime, $mtime) = (stat($from))[8,9];
             utime($atime, $mtime, $to);

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index f01830e..5e75383 100755 (executable)
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -9,7 +9,7 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 48;
+plan tests => 60;
 
 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
@@ -19,6 +19,16 @@ BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
 use File::Copy;
 use Config;
 
+
+foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
+                  "move()", "move('arg')", "move('arg', 'arg', 'arg')"
+                 )
+{
+    eval $code;
+    like $@, qr/^Usage: /;
+}
+
+
 for my $cross_partition_test (0..1) {
   {
     # Simulate a cross-partition copy/move by forcing rename to
@@ -92,7 +102,7 @@ for my $cross_partition_test (0..1) {
   # The destination file will reflect the same difficulties.
   my $mtime = (stat("copy-$$"))[9];
 
-  ok move "copy-$$", "file-$$", 'move';
+  ok move("copy-$$", "file-$$"), 'move';
   ok -e "file-$$",              '  destination exists';
   ok !-e "copy-$$",              '  source does not';
   open(R, "file-$$") or die; $foo = <R>; close(R);
@@ -114,9 +124,14 @@ for my $cross_partition_test (0..1) {
   is $foo, "ok\n";
   unlink "lib/file-$$" or die "unlink: $!";
 
-  eval { copy("file-$$", "file-$$") };
-  like $@, qr/are identical/;
-  ok -s "file-$$";
+  { 
+    my $warnings = '';
+    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+    ok copy("file-$$", "file-$$");
+
+    like $warnings, qr/are identical/;
+    ok -s "file-$$";
+  }
 
   move "file-$$", "lib";
   open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
@@ -125,14 +140,18 @@ for my $cross_partition_test (0..1) {
   unlink "lib/file-$$" or die "unlink: $!";
 
   SKIP: {
-    skip "Testing symlinks", 2 unless $Config{d_symlink};
+    skip "Testing symlinks", 3 unless $Config{d_symlink};
 
     open(F, ">file-$$") or die $!;
     print F "dummy content\n";
     close F;
     symlink("file-$$", "symlink-$$") or die $!;
-    eval { copy("file-$$", "symlink-$$") };
-    like $@, qr/are identical/;
+
+    my $warnings = '';
+    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+    ok !copy("file-$$", "symlink-$$");
+
+    like $warnings, qr/are identical/;
     ok !-z "file-$$", 
       'rt.perl.org 5196: copying to itself would truncate the file';
 
@@ -141,14 +160,18 @@ for my $cross_partition_test (0..1) {
   }
 
   SKIP: {
-    skip "Testing hard links", 2 if !$Config{d_link} or $^O eq 'MSWin32';
+    skip "Testing hard links", 3 if !$Config{d_link} or $^O eq 'MSWin32';
 
     open(F, ">file-$$") or die $!;
     print F "dummy content\n";
     close F;
     link("file-$$", "hardlink-$$") or die $!;
-    eval { copy("file-$$", "hardlink-$$") };
-    like $@, qr/are identical/;
+
+    my $warnings = '';
+    local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+    ok !copy("file-$$", "hardlink-$$");
+
+    like $warnings, qr/are identical/;
     ok ! -z "file-$$",
       'rt.perl.org 5196: copying to itself would truncate the file';