Commit | Line | Data |
671637fe |
1 | #!./perl -w |
1a3850a5 |
2 | |
3 | BEGIN { |
96fe83cd |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | } |
1a3850a5 |
8 | } |
9 | |
81ec4fbc |
10 | use strict; |
11 | use warnings; |
12 | |
83519ebf |
13 | use Test::More; |
1a3850a5 |
14 | |
83519ebf |
15 | my $TB = Test::More->builder; |
16 | |
fff5c6e2 |
17 | plan tests => 463; |
1ef59467 |
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 |
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 |
34 | } |
35 | |
36 | |
1ef59467 |
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 |
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 |
49 | close F; |
50 | |
51 | copy "file-$$", "copy-$$"; |
52 | |
671637fe |
53 | open(F, "copy-$$") or die $!; |
81ec4fbc |
54 | my $foo = <F>; |
1a04d035 |
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 |
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 |
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 |
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 |
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 |
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 |
97 | unlink "file-$$" or die "unlink: $!"; |
98 | |
83519ebf |
99 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
100 | ok -e "copy-$$", ' target still there'; |
1a04d035 |
101 | |
1ef59467 |
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 |
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 |
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 |
129 | open(R, "lib/file-$$") or die $!; $foo = <R>; close(R); |
130 | is $foo, "ok\n", 'copy(fn, dir): same contents'; |
83519ebf |
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 |
137 | unlink "lib/file-$$" or die "unlink: $!"; |
138 | |
754f2cd0 |
139 | { |
140 | my $warnings = ''; |
141 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; |
96fe83cd |
142 | ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds'; |
754f2cd0 |
143 | |
96fe83cd |
144 | like $warnings, qr/are identical/, 'but warns'; |
145 | ok -s "file-$$", 'contents preserved'; |
754f2cd0 |
146 | } |
83519ebf |
147 | |
148 | move "file-$$", "lib"; |
149 | open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); |
96fe83cd |
150 | is $foo, "ok\n", 'move(fn, dir): same contents'; |
151 | ok !-e "file-$$", 'file moved indeed'; |
83519ebf |
152 | unlink "lib/file-$$" or die "unlink: $!"; |
153 | |
154 | SKIP: { |
754f2cd0 |
155 | skip "Testing symlinks", 3 unless $Config{d_symlink}; |
ac7b122d |
156 | |
ac7b122d |
157 | open(F, ">file-$$") or die $!; |
158 | print F "dummy content\n"; |
159 | close F; |
160 | symlink("file-$$", "symlink-$$") or die $!; |
754f2cd0 |
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 |
167 | ok !-z "file-$$", |
168 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
169 | |
671637fe |
170 | unlink "symlink-$$" or die $!; |
171 | unlink "file-$$" or die $!; |
6c254d95 |
172 | } |
ac7b122d |
173 | |
83519ebf |
174 | SKIP: { |
96fe83cd |
175 | skip "Testing hard links", 3 |
176 | if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; |
83519ebf |
177 | |
178 | open(F, ">file-$$") or die $!; |
179 | print F "dummy content\n"; |
180 | close F; |
181 | link("file-$$", "hardlink-$$") or die $!; |
754f2cd0 |
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 |
188 | ok ! -z "file-$$", |
189 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
190 | |
671637fe |
191 | unlink "hardlink-$$" or die $!; |
192 | unlink "file-$$" or die $!; |
ac7b122d |
193 | } |
671637fe |
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 $!; |
fff5c6e2 |
226 | |
227 | # RT #73714 copy to file with leading whitespace failed |
228 | |
69a90d4d |
229 | TODO: { |
230 | local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS'; |
fff5c6e2 |
231 | open(F, ">file-$$") or die $!; |
232 | close F; |
233 | copy "file-$$", " copy-$$"; |
fff5c6e2 |
234 | ok -e " copy-$$", "copy with leading whitespace"; |
235 | unlink "file-$$" or die "unlink: $!"; |
236 | unlink " copy-$$" or die "unlink: $!"; |
69a90d4d |
237 | } |
1a04d035 |
238 | } |
239 | |
441496b2 |
240 | |
32d68040 |
241 | SKIP: { |
20513930 |
242 | my @tests = ( |
243 | [0000, 0777, 0777, 0777], |
244 | [0000, 0751, 0751, 0644], |
245 | [0022, 0777, 0755, 0206], |
246 | [0022, 0415, 0415, 0666], |
247 | [0077, 0777, 0700, 0333], |
248 | [0027, 0755, 0750, 0251], |
249 | [0777, 0751, 0000, 0215], |
250 | ); |
251 | |
252 | my $skips = @tests * 6 * 8; |
32d68040 |
253 | |
9d48bc6d |
254 | # TODO - make this skip fire if we're on a nosuid filesystem rather than guessing by OS |
255 | skip "OpenBSD filesystems default to nosuid breaking these tests", $skips |
256 | if $^O eq 'openbsd'; |
20513930 |
257 | skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips |
258 | if $^O eq 'VMS'; |
259 | skip "Copy doesn't set file permissions correctly on Win32.", $skips |
260 | if $^O eq "MSWin32"; |
32d68040 |
261 | |
81ec4fbc |
262 | # Just a sub to get better failure messages. |
263 | sub __ ($) { |
20513930 |
264 | my $perm = shift; |
265 | my $id = 07000 & $perm; |
266 | $id >>= 9; |
267 | $perm &= 0777; |
268 | my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} |
269 | split // => sprintf "%03o" => $perm; |
270 | if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} |
271 | if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} |
272 | if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} |
273 | join "" => @chunks; |
81ec4fbc |
274 | } |
275 | # Testing permission bits. |
276 | my $src = "file-$$"; |
277 | my $copy1 = "copy1-$$"; |
278 | my $copy2 = "copy2-$$"; |
279 | my $copy3 = "copy3-$$"; |
e63b3379 |
280 | my $copy4 = "copy4-$$"; |
281 | my $copy5 = "copy5-$$"; |
282 | my $copy6 = "copy6-$$"; |
81ec4fbc |
283 | |
284 | open my $fh => ">", $src or die $!; |
285 | close $fh or die $!; |
286 | |
287 | open $fh => ">", $copy3 or die $!; |
288 | close $fh or die $!; |
289 | |
e63b3379 |
290 | open $fh => ">", $copy6 or die $!; |
291 | close $fh or die $!; |
292 | |
81ec4fbc |
293 | my $old_mask = umask; |
294 | foreach my $test (@tests) { |
20513930 |
295 | foreach my $id (0 .. 7) { |
296 | my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; |
297 | # Make sure the copies doesn't exist. |
298 | ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; |
299 | |
300 | $s_perm |= $id << 9; |
301 | $c_perm1 |= $id << 9; |
b1144eba |
302 | diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) |
303 | unless ($ENV{PERL_CORE}); |
76073986 |
304 | |
305 | # Test that we can actually set a file to the correct permission. |
306 | # Slightly convoluted, because some operating systems will let us |
307 | # set a directory, but not a file. These should all work: |
308 | mkdir $copy1 or die "Can't mkdir $copy1: $!"; |
1be14c39 |
309 | chmod $s_perm, $copy1 |
310 | or die sprintf "Can't chmod %o $copy1: $!", $s_perm; |
311 | rmdir $copy1 |
312 | or die sprintf "Can't rmdir $copy1: $!"; |
76073986 |
313 | open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; |
314 | close $fh0 or die "Can't close $copy1: $!"; |
315 | unless (chmod $s_perm, $copy1) { |
316 | $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) |
317 | for 1..6; |
318 | next; |
319 | } |
320 | my $perm0 = (stat $copy1) [2] & 07777; |
321 | unless ($perm0 == $s_perm) { |
322 | $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", |
323 | $s_perm, $perm0) |
324 | for 1..6; |
325 | next; |
326 | } |
327 | unlink $copy1 or die "Can't unlink $copy1: $!"; |
328 | |
20513930 |
329 | (umask $umask) // die $!; |
330 | chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; |
331 | chmod $c_perm3 => $copy3 or die $!; |
332 | chmod $c_perm3 => $copy6 or die $!; |
333 | |
334 | open my $fh => "<", $src or die $!; |
335 | |
336 | copy ($src, $copy1); |
337 | copy ($fh, $copy2); |
338 | copy ($src, $copy3); |
339 | cp ($src, $copy4); |
340 | cp ($fh, $copy5); |
341 | cp ($src, $copy6); |
342 | |
343 | my $permdef = 0666 & ~$umask; |
344 | my $perm1 = (stat $copy1) [2] & 07777; |
345 | my $perm2 = (stat $copy2) [2] & 07777; |
346 | my $perm3 = (stat $copy3) [2] & 07777; |
347 | my $perm4 = (stat $copy4) [2] & 07777; |
348 | my $perm5 = (stat $copy5) [2] & 07777; |
349 | my $perm6 = (stat $copy6) [2] & 07777; |
350 | is (__$perm1, __$permdef, "Permission bits set correctly"); |
351 | is (__$perm2, __$permdef, "Permission bits set correctly"); |
352 | is (__$perm4, __$c_perm1, "Permission bits set correctly"); |
353 | is (__$perm5, __$c_perm1, "Permission bits set correctly"); |
354 | TODO: { |
355 | local $TODO = 'Permission bits inconsistent under cygwin' |
356 | if $^O eq 'cygwin'; |
357 | is (__$perm3, __$c_perm3, "Permission bits not modified"); |
358 | is (__$perm6, __$c_perm3, "Permission bits not modified"); |
359 | } |
c4e1003e |
360 | } |
81ec4fbc |
361 | } |
362 | umask $old_mask or die $!; |
363 | |
364 | # Clean up. |
20513930 |
365 | ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, |
366 | $copy4, $copy5, $copy6; |
81ec4fbc |
367 | } |
368 | |
e55c0a82 |
369 | { |
370 | package Crash; |
371 | # a package overloaded suspiciously like IO::Scalar |
372 | use overload '""' => sub { ${$_[0]} }; |
373 | use overload 'bool' => sub { 1 }; |
374 | sub new { |
375 | my ($class, $name) = @_; |
376 | bless \$name, $class; |
377 | } |
378 | |
379 | package Zowie; |
380 | # a different package overloaded suspiciously like IO::Scalar |
381 | use overload '""' => sub { ${$_[0]} }; |
382 | use overload 'bool' => sub { 1 }; |
383 | sub new { |
384 | my ($class, $name) = @_; |
385 | bless \$name, $class; |
386 | } |
387 | } |
388 | { |
389 | my $object = Crash->new('whack_eth'); |
390 | my %what = (plain => "$object", |
391 | object1 => $object, |
392 | object2 => Zowie->new('whack_eth'), |
393 | object2 => Zowie->new('whack_eth'), |
394 | ); |
395 | |
396 | my @warnings; |
397 | local $SIG{__WARN__} = sub { |
398 | push @warnings, @_; |
399 | }; |
400 | |
401 | foreach my $left (qw(plain object1 object2)) { |
402 | foreach my $right (qw(plain object1 object2)) { |
403 | @warnings = (); |
404 | $! = 0; |
405 | is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right"; |
406 | is $@, '', 'No croaking'; |
407 | is $!, '', 'No system call errors'; |
408 | is @warnings, 1, 'Exactly 1 warning'; |
409 | like $warnings[0], |
410 | qr/'$object' and '$object' are identical \(not copied\)/, |
411 | 'with the text we expect'; |
412 | } |
413 | } |
414 | } |
81ec4fbc |
415 | |
079cb8cc |
416 | # On Unix systems, File::Copy always returns 0 to signal failure, |
417 | # even when in list context! On Windows, it always returns "" to signal |
418 | # failure. |
419 | # |
420 | # While returning a list containing a false value is arguably a bad |
421 | # API design, at the very least we can make sure it always returns |
422 | # the same false value. |
423 | |
424 | my $NO_SUCH_FILE = "this_file_had_better_not_exist"; |
425 | my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; |
426 | |
427 | use constant EXPECTED_SCALAR => 0; |
428 | use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; |
429 | |
430 | my %subs = ( |
431 | copy => \&File::Copy::copy, |
432 | cp => \&File::Copy::cp, |
433 | move => \&File::Copy::move, |
434 | mv => \&File::Copy::mv, |
435 | ); |
436 | |
437 | SKIP: { |
438 | skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) |
439 | if (-e $NO_SUCH_FILE); |
440 | |
441 | foreach my $name (keys %subs) { |
442 | |
443 | my $sub = $subs{$name}; |
444 | |
445 | my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); |
446 | is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); |
447 | |
448 | my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); |
449 | is_deeply( \@array, EXPECTED_LIST, "$name in list context"); |
450 | } |
451 | } |
452 | |
16f708c9 |
453 | SKIP: { |
454 | skip("fork required to test pipe copying", 2) |
455 | if (!$Config{'d_fork'}); |
456 | |
457 | open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; |
458 | open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; |
459 | |
460 | ok(copy($IN, $OUT), "copy pipe to another"); |
461 | close($OUT); |
462 | is($? >> 8, 55, "content copied through the pipes"); |
463 | close($IN); |
464 | } |
465 | |
cfcb0b09 |
466 | END { |
467 | 1 while unlink "file-$$"; |
83519ebf |
468 | 1 while unlink "lib/file-$$"; |
cfcb0b09 |
469 | } |