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);
112 local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS';
114 my $dest_mtime = (stat("file-$$"))[9];
115 is $dest_mtime, $mtime,
116 "mtime preserved by copy()".
117 ($cross_partition_test ? " while testing cross-partition" : "");
120 copy "file-$$", "lib";
121 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
123 unlink "lib/file-$$" or die "unlink: $!";
125 # Do it twice to ensure copying over the same file works.
126 copy "file-$$", "lib";
127 open(R, "lib/file-$$") or die; $foo = <R>; close(R);
129 unlink "lib/file-$$" or die "unlink: $!";
133 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
134 ok copy("file-$$", "file-$$");
136 like $warnings, qr/are identical/;
140 move "file-$$", "lib";
141 open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
144 unlink "lib/file-$$" or die "unlink: $!";
147 skip "Testing symlinks", 3 unless $Config{d_symlink};
149 open(F, ">file-$$") or die $!;
150 print F "dummy content\n";
152 symlink("file-$$", "symlink-$$") or die $!;
155 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
156 ok !copy("file-$$", "symlink-$$");
158 like $warnings, qr/are identical/;
160 'rt.perl.org 5196: copying to itself would truncate the file';
167 skip "Testing hard links", 3 if !$Config{d_link} or $^O eq 'MSWin32';
169 open(F, ">file-$$") or die $!;
170 print F "dummy content\n";
172 link("file-$$", "hardlink-$$") or die $!;
175 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
176 ok !copy("file-$$", "hardlink-$$");
178 like $warnings, qr/are identical/;
180 'rt.perl.org 5196: copying to itself would truncate the file';
182 unlink "hardlink-$$";
189 1 while unlink "file-$$";
190 1 while unlink "lib/file-$$";