Commit | Line | Data |
---|---|---|
671637fe | 1 | #!./perl -w |
1a3850a5 GA |
2 | |
3 | BEGIN { | |
96fe83cd AF |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | } | |
1a3850a5 GA |
8 | } |
9 | ||
81ec4fbc A |
10 | use strict; |
11 | use warnings; | |
12 | ||
83519ebf | 13 | use Test::More; |
1a3850a5 | 14 | |
83519ebf MS |
15 | my $TB = Test::More->builder; |
16 | ||
20513930 | 17 | plan tests => 451; |
1ef59467 MS |
18 | |
19 | # We're going to override rename() later on but Perl has to see an override | |
20 | # at compile time to honor it. | |
21 | BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; } | |
22 | ||
1a04d035 | 23 | |
e63b3379 | 24 | use File::Copy qw(copy move cp); |
ac7b122d | 25 | use Config; |
1a3850a5 | 26 | |
754f2cd0 MS |
27 | |
28 | foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')", | |
29 | "move()", "move('arg')", "move('arg', 'arg', 'arg')" | |
30 | ) | |
31 | { | |
32 | eval $code; | |
96fe83cd | 33 | like $@, qr/^Usage: /, "'$code' is a usage error"; |
754f2cd0 MS |
34 | } |
35 | ||
36 | ||
1ef59467 MS |
37 | for my $cross_partition_test (0..1) { |
38 | { | |
39 | # Simulate a cross-partition copy/move by forcing rename to | |
40 | # fail. | |
41 | no warnings 'redefine'; | |
42 | *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test; | |
43 | } | |
1a04d035 A |
44 | |
45 | # First we create a file | |
671637fe | 46 | open(F, ">file-$$") or die $!; |
1a04d035 | 47 | binmode F; # for DOSISH platforms, because test 3 copies to stdout |
83519ebf | 48 | printf F "ok\n"; |
1a04d035 A |
49 | close F; |
50 | ||
51 | copy "file-$$", "copy-$$"; | |
52 | ||
671637fe | 53 | open(F, "copy-$$") or die $!; |
81ec4fbc | 54 | my $foo = <F>; |
1a04d035 A |
55 | close(F); |
56 | ||
96fe83cd | 57 | is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; |
1a04d035 | 58 | |
96fe83cd | 59 | is $foo, "ok\n", 'copy(fn, fn): same contents'; |
1a04d035 | 60 | |
96fe83cd | 61 | print("# next test checks copying to STDOUT\n"); |
1a04d035 | 62 | binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode |
83519ebf | 63 | # This outputs "ok" so its a test. |
1a04d035 | 64 | copy "copy-$$", \*STDOUT; |
83519ebf | 65 | $TB->current_test($TB->current_test + 1); |
1a04d035 A |
66 | unlink "copy-$$" or die "unlink: $!"; |
67 | ||
68 | open(F,"file-$$"); | |
69 | copy(*F, "copy-$$"); | |
70 | open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); | |
96fe83cd | 71 | is $foo, "ok\n", 'copy(*F, fn): same contents'; |
1a04d035 | 72 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf | 73 | |
1a04d035 A |
74 | open(F,"file-$$"); |
75 | copy(\*F, "copy-$$"); | |
76 | close(F) or die "close: $!"; | |
77 | open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; | |
96fe83cd | 78 | is $foo, "ok\n", 'copy(\*F, fn): same contents'; |
1a04d035 A |
79 | unlink "copy-$$" or die "unlink: $!"; |
80 | ||
81 | require IO::File; | |
81ec4fbc | 82 | my $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
671637fe | 83 | binmode $fh or die $!; |
1a04d035 A |
84 | copy("file-$$",$fh); |
85 | $fh->close or die "close: $!"; | |
86 | open(R, "copy-$$") or die; $foo = <R>; close(R); | |
96fe83cd | 87 | is $foo, "ok\n", 'copy(fn, io): same contents'; |
1a04d035 | 88 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf | 89 | |
1a04d035 | 90 | require FileHandle; |
81ec4fbc | 91 | $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
671637fe | 92 | binmode $fh or die $!; |
1a04d035 A |
93 | copy("file-$$",$fh); |
94 | $fh->close; | |
671637fe | 95 | open(R, "copy-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 96 | is $foo, "ok\n", 'copy(fn, fh): same contents'; |
1a04d035 A |
97 | unlink "file-$$" or die "unlink: $!"; |
98 | ||
83519ebf MS |
99 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
100 | ok -e "copy-$$", ' target still there'; | |
1a04d035 | 101 | |
1ef59467 MS |
102 | # Doesn't really matter what time it is as long as its not now. |
103 | my $time = 1000000000; | |
104 | utime( $time, $time, "copy-$$" ); | |
105 | ||
106 | # Recheck the mtime rather than rely on utime in case we're on a | |
107 | # system where utime doesn't work or there's no mtime at all. | |
108 | # The destination file will reflect the same difficulties. | |
109 | my $mtime = (stat("copy-$$"))[9]; | |
110 | ||
754f2cd0 | 111 | ok move("copy-$$", "file-$$"), 'move'; |
83519ebf MS |
112 | ok -e "file-$$", ' destination exists'; |
113 | ok !-e "copy-$$", ' source does not'; | |
671637fe | 114 | open(R, "file-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 115 | is $foo, "ok\n", 'contents preserved'; |
83519ebf | 116 | |
e9e3be28 CB |
117 | TODO: { |
118 | local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS'; | |
119 | ||
120 | my $dest_mtime = (stat("file-$$"))[9]; | |
121 | is $dest_mtime, $mtime, | |
122 | "mtime preserved by copy()". | |
123 | ($cross_partition_test ? " while testing cross-partition" : ""); | |
124 | } | |
1ef59467 | 125 | |
96fe83cd | 126 | # trick: create lib/ if not exists - not needed in Perl core |
671637fe | 127 | unless (-d 'lib') { mkdir 'lib' or die $!; } |
83519ebf | 128 | copy "file-$$", "lib"; |
96fe83cd AF |
129 | open(R, "lib/file-$$") or die $!; $foo = <R>; close(R); |
130 | is $foo, "ok\n", 'copy(fn, dir): same contents'; | |
83519ebf MS |
131 | unlink "lib/file-$$" or die "unlink: $!"; |
132 | ||
133 | # Do it twice to ensure copying over the same file works. | |
134 | copy "file-$$", "lib"; | |
671637fe | 135 | open(R, "lib/file-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 136 | is $foo, "ok\n", 'copy over the same file works'; |
83519ebf MS |
137 | unlink "lib/file-$$" or die "unlink: $!"; |
138 | ||
754f2cd0 MS |
139 | { |
140 | my $warnings = ''; | |
141 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
96fe83cd | 142 | ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds'; |
754f2cd0 | 143 | |
96fe83cd AF |
144 | like $warnings, qr/are identical/, 'but warns'; |
145 | ok -s "file-$$", 'contents preserved'; | |
754f2cd0 | 146 | } |
83519ebf MS |
147 | |
148 | move "file-$$", "lib"; | |
149 | open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); | |
96fe83cd AF |
150 | is $foo, "ok\n", 'move(fn, dir): same contents'; |
151 | ok !-e "file-$$", 'file moved indeed'; | |
83519ebf MS |
152 | unlink "lib/file-$$" or die "unlink: $!"; |
153 | ||
154 | SKIP: { | |
754f2cd0 | 155 | skip "Testing symlinks", 3 unless $Config{d_symlink}; |
ac7b122d | 156 | |
ac7b122d SR |
157 | open(F, ">file-$$") or die $!; |
158 | print F "dummy content\n"; | |
159 | close F; | |
160 | symlink("file-$$", "symlink-$$") or die $!; | |
754f2cd0 MS |
161 | |
162 | my $warnings = ''; | |
163 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
96fe83cd | 164 | ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; |
754f2cd0 | 165 | |
96fe83cd | 166 | like $warnings, qr/are identical/, 'emits a warning'; |
83519ebf MS |
167 | ok !-z "file-$$", |
168 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
169 | ||
671637fe NC |
170 | unlink "symlink-$$" or die $!; |
171 | unlink "file-$$" or die $!; | |
6c254d95 | 172 | } |
ac7b122d | 173 | |
83519ebf | 174 | SKIP: { |
96fe83cd AF |
175 | skip "Testing hard links", 3 |
176 | if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; | |
83519ebf MS |
177 | |
178 | open(F, ">file-$$") or die $!; | |
179 | print F "dummy content\n"; | |
180 | close F; | |
181 | link("file-$$", "hardlink-$$") or die $!; | |
754f2cd0 MS |
182 | |
183 | my $warnings = ''; | |
184 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
96fe83cd | 185 | ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; |
754f2cd0 | 186 | |
96fe83cd | 187 | like $warnings, qr/are identical/, 'emits a warning'; |
83519ebf MS |
188 | ok ! -z "file-$$", |
189 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
190 | ||
671637fe NC |
191 | unlink "hardlink-$$" or die $!; |
192 | unlink "file-$$" or die $!; | |
ac7b122d | 193 | } |
671637fe NC |
194 | |
195 | open(F, ">file-$$") or die $!; | |
196 | binmode F; | |
197 | print F "this is file\n"; | |
198 | close F; | |
199 | ||
200 | my $copy_msg = "this is copy\n"; | |
201 | open(F, ">copy-$$") or die $!; | |
202 | binmode F; | |
203 | print F $copy_msg; | |
204 | close F; | |
205 | ||
206 | my @warnings; | |
207 | local $SIG{__WARN__} = sub { push @warnings, join '', @_ }; | |
208 | ||
209 | # pie-$$ so that we force a non-constant, else the numeric conversion (of 0) | |
210 | # is cached and we don't get a warning the second time round | |
211 | is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef, | |
212 | "a bad buffer size fails to copy"; | |
213 | like $@, qr/Bad buffer size for copy/, "with a helpful error message"; | |
214 | unless (is scalar @warnings, 1, "There is 1 warning") { | |
215 | diag $_ foreach @warnings; | |
216 | } | |
217 | ||
218 | is -s "copy-$$", length $copy_msg, "but does not truncate the destination"; | |
219 | open(F, "copy-$$") or die $!; | |
220 | $foo = <F>; | |
221 | close(F); | |
222 | is $foo, $copy_msg, "nor change the destination's contents"; | |
223 | ||
224 | unlink "file-$$" or die $!; | |
225 | unlink "copy-$$" or die $!; | |
1a04d035 A |
226 | } |
227 | ||
441496b2 | 228 | |
32d68040 | 229 | SKIP: { |
20513930 A |
230 | my @tests = ( |
231 | [0000, 0777, 0777, 0777], | |
232 | [0000, 0751, 0751, 0644], | |
233 | [0022, 0777, 0755, 0206], | |
234 | [0022, 0415, 0415, 0666], | |
235 | [0077, 0777, 0700, 0333], | |
236 | [0027, 0755, 0750, 0251], | |
237 | [0777, 0751, 0000, 0215], | |
238 | ); | |
239 | ||
240 | my $skips = @tests * 6 * 8; | |
32d68040 | 241 | |
20513930 A |
242 | skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips |
243 | if $^O eq 'VMS'; | |
244 | skip "Copy doesn't set file permissions correctly on Win32.", $skips | |
245 | if $^O eq "MSWin32"; | |
32d68040 | 246 | |
81ec4fbc A |
247 | # Just a sub to get better failure messages. |
248 | sub __ ($) { | |
20513930 A |
249 | my $perm = shift; |
250 | my $id = 07000 & $perm; | |
251 | $id >>= 9; | |
252 | $perm &= 0777; | |
253 | my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} | |
254 | split // => sprintf "%03o" => $perm; | |
255 | if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} | |
256 | if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} | |
257 | if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} | |
258 | join "" => @chunks; | |
81ec4fbc A |
259 | } |
260 | # Testing permission bits. | |
261 | my $src = "file-$$"; | |
262 | my $copy1 = "copy1-$$"; | |
263 | my $copy2 = "copy2-$$"; | |
264 | my $copy3 = "copy3-$$"; | |
e63b3379 CB |
265 | my $copy4 = "copy4-$$"; |
266 | my $copy5 = "copy5-$$"; | |
267 | my $copy6 = "copy6-$$"; | |
81ec4fbc A |
268 | |
269 | open my $fh => ">", $src or die $!; | |
270 | close $fh or die $!; | |
271 | ||
272 | open $fh => ">", $copy3 or die $!; | |
273 | close $fh or die $!; | |
274 | ||
e63b3379 CB |
275 | open $fh => ">", $copy6 or die $!; |
276 | close $fh or die $!; | |
277 | ||
81ec4fbc A |
278 | my $old_mask = umask; |
279 | foreach my $test (@tests) { | |
20513930 A |
280 | foreach my $id (0 .. 7) { |
281 | my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; | |
282 | # Make sure the copies doesn't exist. | |
283 | ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; | |
284 | ||
285 | $s_perm |= $id << 9; | |
286 | $c_perm1 |= $id << 9; | |
b1144eba JH |
287 | diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) |
288 | unless ($ENV{PERL_CORE}); | |
20513930 A |
289 | (umask $umask) // die $!; |
290 | chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; | |
291 | chmod $c_perm3 => $copy3 or die $!; | |
292 | chmod $c_perm3 => $copy6 or die $!; | |
293 | ||
294 | open my $fh => "<", $src or die $!; | |
295 | ||
296 | copy ($src, $copy1); | |
297 | copy ($fh, $copy2); | |
298 | copy ($src, $copy3); | |
299 | cp ($src, $copy4); | |
300 | cp ($fh, $copy5); | |
301 | cp ($src, $copy6); | |
302 | ||
303 | my $permdef = 0666 & ~$umask; | |
304 | my $perm1 = (stat $copy1) [2] & 07777; | |
305 | my $perm2 = (stat $copy2) [2] & 07777; | |
306 | my $perm3 = (stat $copy3) [2] & 07777; | |
307 | my $perm4 = (stat $copy4) [2] & 07777; | |
308 | my $perm5 = (stat $copy5) [2] & 07777; | |
309 | my $perm6 = (stat $copy6) [2] & 07777; | |
310 | is (__$perm1, __$permdef, "Permission bits set correctly"); | |
311 | is (__$perm2, __$permdef, "Permission bits set correctly"); | |
312 | is (__$perm4, __$c_perm1, "Permission bits set correctly"); | |
313 | is (__$perm5, __$c_perm1, "Permission bits set correctly"); | |
314 | TODO: { | |
315 | local $TODO = 'Permission bits inconsistent under cygwin' | |
316 | if $^O eq 'cygwin'; | |
317 | is (__$perm3, __$c_perm3, "Permission bits not modified"); | |
318 | is (__$perm6, __$c_perm3, "Permission bits not modified"); | |
319 | } | |
c4e1003e | 320 | } |
81ec4fbc A |
321 | } |
322 | umask $old_mask or die $!; | |
323 | ||
324 | # Clean up. | |
20513930 A |
325 | ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, |
326 | $copy4, $copy5, $copy6; | |
81ec4fbc A |
327 | } |
328 | ||
e55c0a82 PR |
329 | { |
330 | package Crash; | |
331 | # a package overloaded suspiciously like IO::Scalar | |
332 | use overload '""' => sub { ${$_[0]} }; | |
333 | use overload 'bool' => sub { 1 }; | |
334 | sub new { | |
335 | my ($class, $name) = @_; | |
336 | bless \$name, $class; | |
337 | } | |
338 | ||
339 | package Zowie; | |
340 | # a different package overloaded suspiciously like IO::Scalar | |
341 | use overload '""' => sub { ${$_[0]} }; | |
342 | use overload 'bool' => sub { 1 }; | |
343 | sub new { | |
344 | my ($class, $name) = @_; | |
345 | bless \$name, $class; | |
346 | } | |
347 | } | |
348 | { | |
349 | my $object = Crash->new('whack_eth'); | |
350 | my %what = (plain => "$object", | |
351 | object1 => $object, | |
352 | object2 => Zowie->new('whack_eth'), | |
353 | object2 => Zowie->new('whack_eth'), | |
354 | ); | |
355 | ||
356 | my @warnings; | |
357 | local $SIG{__WARN__} = sub { | |
358 | push @warnings, @_; | |
359 | }; | |
360 | ||
361 | foreach my $left (qw(plain object1 object2)) { | |
362 | foreach my $right (qw(plain object1 object2)) { | |
363 | @warnings = (); | |
364 | $! = 0; | |
365 | is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right"; | |
366 | is $@, '', 'No croaking'; | |
367 | is $!, '', 'No system call errors'; | |
368 | is @warnings, 1, 'Exactly 1 warning'; | |
369 | like $warnings[0], | |
370 | qr/'$object' and '$object' are identical \(not copied\)/, | |
371 | 'with the text we expect'; | |
372 | } | |
373 | } | |
374 | } | |
81ec4fbc | 375 | |
cfcb0b09 JH |
376 | END { |
377 | 1 while unlink "file-$$"; | |
83519ebf | 378 | 1 while unlink "lib/file-$$"; |
cfcb0b09 | 379 | } |