4 if( $ENV{PERL_CORE} ) {
12 my $TB = Test::More->builder;
16 # We're going to override rename() later on but Perl has to see an override
17 # at compile time to honor it.
18 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
25 foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
26 "move()", "move('arg')", "move('arg', 'arg', 'arg')"
30 like $@, qr/^Usage: /, "'$code' is a usage error";
34 for my $cross_partition_test (0..1) {
36 # Simulate a cross-partition copy/move by forcing rename to
38 no warnings 'redefine';
39 *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
42 # First we create a file
43 open(F, ">file-$$") or die $!;
44 binmode F; # for DOSISH platforms, because test 3 copies to stdout
48 copy "file-$$", "copy-$$";
50 open(F, "copy-$$") or die $!;
54 is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size';
56 is $foo, "ok\n", 'copy(fn, fn): same contents';
58 print("# next test checks copying to STDOUT\n");
59 binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
60 # This outputs "ok" so its a test.
61 copy "copy-$$", \*STDOUT;
62 $TB->current_test($TB->current_test + 1);
63 unlink "copy-$$" or die "unlink: $!";
67 open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
68 is $foo, "ok\n", 'copy(*F, fn): same contents';
69 unlink "copy-$$" or die "unlink: $!";
73 close(F) or die "close: $!";
74 open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
75 is $foo, "ok\n", 'copy(\*F, fn): same contents';
76 unlink "copy-$$" or die "unlink: $!";
79 $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
80 binmode $fh or die $!;
82 $fh->close or die "close: $!";
83 open(R, "copy-$$") or die; $foo = <R>; close(R);
84 is $foo, "ok\n", 'copy(fn, io): same contents';
85 unlink "copy-$$" or die "unlink: $!";
88 my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
89 binmode $fh or die $!;
92 open(R, "copy-$$") or die $!; $foo = <R>; close(R);
93 is $foo, "ok\n", 'copy(fn, fh): same contents';
94 unlink "file-$$" or die "unlink: $!";
96 ok !move("file-$$", "copy-$$"), "move on missing file";
97 ok -e "copy-$$", ' target still there';
99 # Doesn't really matter what time it is as long as its not now.
100 my $time = 1000000000;
101 utime( $time, $time, "copy-$$" );
103 # Recheck the mtime rather than rely on utime in case we're on a
104 # system where utime doesn't work or there's no mtime at all.
105 # The destination file will reflect the same difficulties.
106 my $mtime = (stat("copy-$$"))[9];
108 ok move("copy-$$", "file-$$"), 'move';
109 ok -e "file-$$", ' destination exists';
110 ok !-e "copy-$$", ' source does not';
111 open(R, "file-$$") or die $!; $foo = <R>; close(R);
112 is $foo, "ok\n", 'contents preserved';
115 local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS';
117 my $dest_mtime = (stat("file-$$"))[9];
118 is $dest_mtime, $mtime,
119 "mtime preserved by copy()".
120 ($cross_partition_test ? " while testing cross-partition" : "");
123 # trick: create lib/ if not exists - not needed in Perl core
124 unless (-d 'lib') { mkdir 'lib' or die $!; }
125 copy "file-$$", "lib";
126 open(R, "lib/file-$$") or die $!; $foo = <R>; close(R);
127 is $foo, "ok\n", 'copy(fn, dir): same contents';
128 unlink "lib/file-$$" or die "unlink: $!";
130 # Do it twice to ensure copying over the same file works.
131 copy "file-$$", "lib";
132 open(R, "lib/file-$$") or die $!; $foo = <R>; close(R);
133 is $foo, "ok\n", 'copy over the same file works';
134 unlink "lib/file-$$" or die "unlink: $!";
138 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
139 ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds';
141 like $warnings, qr/are identical/, 'but warns';
142 ok -s "file-$$", 'contents preserved';
145 move "file-$$", "lib";
146 open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
147 is $foo, "ok\n", 'move(fn, dir): same contents';
148 ok !-e "file-$$", 'file moved indeed';
149 unlink "lib/file-$$" or die "unlink: $!";
152 skip "Testing symlinks", 3 unless $Config{d_symlink};
154 open(F, ">file-$$") or die $!;
155 print F "dummy content\n";
157 symlink("file-$$", "symlink-$$") or die $!;
160 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
161 ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails';
163 like $warnings, qr/are identical/, 'emits a warning';
165 'rt.perl.org 5196: copying to itself would truncate the file';
167 unlink "symlink-$$" or die $!;
168 unlink "file-$$" or die $!;
172 skip "Testing hard links", 3
173 if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin';
175 open(F, ">file-$$") or die $!;
176 print F "dummy content\n";
178 link("file-$$", "hardlink-$$") or die $!;
181 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
182 ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails';
184 like $warnings, qr/are identical/, 'emits a warning';
186 'rt.perl.org 5196: copying to itself would truncate the file';
188 unlink "hardlink-$$" or die $!;
189 unlink "file-$$" or die $!;
192 open(F, ">file-$$") or die $!;
194 print F "this is file\n";
197 my $copy_msg = "this is copy\n";
198 open(F, ">copy-$$") or die $!;
204 local $SIG{__WARN__} = sub { push @warnings, join '', @_ };
206 # pie-$$ so that we force a non-constant, else the numeric conversion (of 0)
207 # is cached and we don't get a warning the second time round
208 is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef,
209 "a bad buffer size fails to copy";
210 like $@, qr/Bad buffer size for copy/, "with a helpful error message";
211 unless (is scalar @warnings, 1, "There is 1 warning") {
212 diag $_ foreach @warnings;
215 is -s "copy-$$", length $copy_msg, "but does not truncate the destination";
216 open(F, "copy-$$") or die $!;
219 is $foo, $copy_msg, "nor change the destination's contents";
221 unlink "file-$$" or die $!;
222 unlink "copy-$$" or die $!;
227 1 while unlink "file-$$";
228 1 while unlink "lib/file-$$";