Comply with the 0x80th commandment

[perl5.git] / lib / File / Copy.t

diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index 557a0e1..db94cc3 100755 (executable)
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -9,12 +9,33 @@ use Test::More;
 
 my $TB = Test::More->builder;
 
-plan tests => 46;
+plan tests => 60;
+
+# We're going to override rename() later on but Perl has to see an override
+# at compile time to honor it.
+BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
+
 
 use File::Copy;
 use Config;
 
-for (1..2) {
+
+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
+    # fail.
+    no warnings 'redefine';
+    *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
+  }
 
   # First we create a file
   open(F, ">file-$$") or die;
@@ -72,12 +93,30 @@ for (1..2) {
   ok !move("file-$$", "copy-$$"), "move on missing file";
   ok -e "copy-$$",                '  target still there';
 
-  ok move "copy-$$", "file-$$", 'move';
+  # Doesn't really matter what time it is as long as its not now.
+  my $time = 1000000000;
+  utime( $time, $time, "copy-$$" );
+
+  # Recheck the mtime rather than rely on utime in case we're on a
+  # system where utime doesn't work or there's no mtime at all.
+  # The destination file will reflect the same difficulties.
+  my $mtime = (stat("copy-$$"))[9];
+
+  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);
   is $foo, "ok\n";
 
+  TODO: {
+    local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS';
+
+    my $dest_mtime = (stat("file-$$"))[9];
+    is $dest_mtime, $mtime,
+      "mtime preserved by copy()". 
+      ($cross_partition_test ? " while testing cross-partition" : "");
+  }
+
   copy "file-$$", "lib";
   open(R, "lib/file-$$") or die; $foo = <R>; close(R);
   is $foo, "ok\n";
@@ -89,9 +128,14 @@ for (1..2) {
   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);
@@ -100,14 +144,18 @@ for (1..2) {
   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';
 
@@ -116,21 +164,24 @@ for (1..2) {
   }
 
   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';
 
     unlink "hardlink-$$";
     unlink "file-$$";
   }
-
 }