10 my $TB = Test::More->builder;
14 # We're going to override rename() later on but Perl has to see an override
15 # at compile time to honor it.
16 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
22 for my $cross_partition_test (0..1) {
24 # Simulate a cross-partition copy/move by forcing rename to
26 no warnings 'redefine';
27 *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
30 # First we create a file
31 open(F, ">file-$$") or die;
32 binmode F; # for DOSISH platforms, because test 3 copies to stdout
36 copy "file-$$", "copy-$$";
38 open(F, "copy-$$") or die;
42 is -s "file-$$", -s "copy-$$";
46 binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
47 # This outputs "ok" so its a test.
48 copy "copy-$$", \*STDOUT;
49 $TB->current_test($TB->current_test + 1);
50 unlink "copy-$$" or die "unlink: $!";
54 open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
56 unlink "copy-$$" or die "unlink: $!";
60 close(F) or die "close: $!";
61 open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
63 unlink "copy-$$" or die "unlink: $!";
66 $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
69 $fh->close or die "close: $!";
70 open(R, "copy-$$") or die; $foo = <R>; close(R);
72 unlink "copy-$$" or die "unlink: $!";
75 my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
79 open(R, "copy-$$") or die; $foo = <R>; close(R);
81 unlink "file-$$" or die "unlink: $!";
83 ok !move("file-$$", "copy-$$"), "move on missing file";
84 ok -e "copy-$$", ' target still there';
86 # Doesn't really matter what time it is as long as its not now.
87 my $time = 1000000000;
88 utime( $time, $time, "copy-$$" );
90 # Recheck the mtime rather than rely on utime in case we're on a
91 # system where utime doesn't work or there's no mtime at all.
92 # The destination file will reflect the same difficulties.
93 my $mtime = (stat("copy-$$"))[9];
95 ok move "copy-$$", "file-$$", 'move';
96 ok -e "file-$$", ' destination exists';
97 ok !-e "copy-$$", ' source does not';
98 open(R, "file-$$") or die; $foo = <R>; close(R);
101 my $dest_mtime = (stat("file-$$"))[9];
102 is $dest_mtime, $mtime,
103 "mtime preserved by copy()".
104 ($cross_partition_test ? " while testing cross-partition" : "");
106 copy "file-$$", "lib";
107 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
109 unlink "lib/file-$$" or die "unlink: $!";
111 # Do it twice to ensure copying over the same file works.
112 copy "file-$$", "lib";
113 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
115 unlink "lib/file-$$" or die "unlink: $!";
117 eval { copy("file-$$", "file-$$") };
118 like $@, qr/are identical/;
121 move "file-$$", "lib";
122 open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
125 unlink "lib/file-$$" or die "unlink: $!";
128 skip "Testing symlinks", 2 unless $Config{d_symlink};
130 open(F, ">file-$$") or die $!;
131 print F "dummy content\n";
133 symlink("file-$$", "symlink-$$") or die $!;
134 eval { copy("file-$$", "symlink-$$") };
135 like $@, qr/are identical/;
137 'rt.perl.org 5196: copying to itself would truncate the file';
144 skip "Testing hard links", 2 if !$Config{d_link} or $^O eq 'MSWin32';
146 open(F, ">file-$$") or die $!;
147 print F "dummy content\n";
149 link("file-$$", "hardlink-$$") or die $!;
150 eval { copy("file-$$", "hardlink-$$") };
151 like $@, qr/are identical/;
153 'rt.perl.org 5196: copying to itself would truncate the file';
155 unlink "hardlink-$$";
162 1 while unlink "file-$$";
163 1 while unlink "lib/file-$$";