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]) }; }
23 foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
24 "move()", "move('arg')", "move('arg', 'arg', 'arg')"
28 like $@, qr/^Usage: /;
32 for my $cross_partition_test (0..1) {
34 # Simulate a cross-partition copy/move by forcing rename to
36 no warnings 'redefine';
37 *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
40 # First we create a file
41 open(F, ">file-$$") or die;
42 binmode F; # for DOSISH platforms, because test 3 copies to stdout
46 copy "file-$$", "copy-$$";
48 open(F, "copy-$$") or die;
52 is -s "file-$$", -s "copy-$$";
56 binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
57 # This outputs "ok" so its a test.
58 copy "copy-$$", \*STDOUT;
59 $TB->current_test($TB->current_test + 1);
60 unlink "copy-$$" or die "unlink: $!";
64 open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
66 unlink "copy-$$" or die "unlink: $!";
70 close(F) or die "close: $!";
71 open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
73 unlink "copy-$$" or die "unlink: $!";
76 $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
79 $fh->close or die "close: $!";
80 open(R, "copy-$$") or die; $foo = <R>; close(R);
82 unlink "copy-$$" or die "unlink: $!";
85 my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
89 open(R, "copy-$$") or die; $foo = <R>; close(R);
91 unlink "file-$$" or die "unlink: $!";
93 ok !move("file-$$", "copy-$$"), "move on missing file";
94 ok -e "copy-$$", ' target still there';
96 # Doesn't really matter what time it is as long as its not now.
97 my $time = 1000000000;
98 utime( $time, $time, "copy-$$" );
100 # Recheck the mtime rather than rely on utime in case we're on a
101 # system where utime doesn't work or there's no mtime at all.
102 # The destination file will reflect the same difficulties.
103 my $mtime = (stat("copy-$$"))[9];
105 ok move("copy-$$", "file-$$"), 'move';
106 ok -e "file-$$", ' destination exists';
107 ok !-e "copy-$$", ' source does not';
108 open(R, "file-$$") or die; $foo = <R>; close(R);
111 my $dest_mtime = (stat("file-$$"))[9];
112 is $dest_mtime, $mtime,
113 "mtime preserved by copy()".
114 ($cross_partition_test ? " while testing cross-partition" : "");
116 copy "file-$$", "lib";
117 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
119 unlink "lib/file-$$" or die "unlink: $!";
121 # Do it twice to ensure copying over the same file works.
122 copy "file-$$", "lib";
123 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
125 unlink "lib/file-$$" or die "unlink: $!";
129 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
130 ok copy("file-$$", "file-$$");
132 like $warnings, qr/are identical/;
136 move "file-$$", "lib";
137 open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
140 unlink "lib/file-$$" or die "unlink: $!";
143 skip "Testing symlinks", 3 unless $Config{d_symlink};
145 open(F, ">file-$$") or die $!;
146 print F "dummy content\n";
148 symlink("file-$$", "symlink-$$") or die $!;
151 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
152 ok !copy("file-$$", "symlink-$$");
154 like $warnings, qr/are identical/;
156 'rt.perl.org 5196: copying to itself would truncate the file';
163 skip "Testing hard links", 3 if !$Config{d_link} or $^O eq 'MSWin32';
165 open(F, ">file-$$") or die $!;
166 print F "dummy content\n";
168 link("file-$$", "hardlink-$$") or die $!;
171 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
172 ok !copy("file-$$", "hardlink-$$");
174 like $warnings, qr/are identical/;
176 'rt.perl.org 5196: copying to itself would truncate the file';
178 unlink "hardlink-$$";
185 1 while unlink "file-$$";
186 1 while unlink "lib/file-$$";