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 | ||
bd86609c | 17 | # We are going to override rename() later on but Perl has to see an override |
1ef59467 MS |
18 | # at compile time to honor it. |
19 | BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; } | |
20 | ||
1a04d035 | 21 | |
e63b3379 | 22 | use File::Copy qw(copy move cp); |
ac7b122d | 23 | use Config; |
1a3850a5 | 24 | |
310d0155 AF |
25 | # If we have Time::HiRes, File::Copy loaded it for us. |
26 | BEGIN { | |
27 | eval { Time::HiRes->import(qw( stat utime )) }; | |
28 | note "Testing Time::HiRes::utime support" unless $@; | |
29 | } | |
754f2cd0 MS |
30 | |
31 | foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')", | |
32 | "move()", "move('arg')", "move('arg', 'arg', 'arg')" | |
33 | ) | |
34 | { | |
35 | eval $code; | |
96fe83cd | 36 | like $@, qr/^Usage: /, "'$code' is a usage error"; |
754f2cd0 MS |
37 | } |
38 | ||
39 | ||
1ef59467 MS |
40 | for my $cross_partition_test (0..1) { |
41 | { | |
42 | # Simulate a cross-partition copy/move by forcing rename to | |
43 | # fail. | |
44 | no warnings 'redefine'; | |
45 | *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test; | |
46 | } | |
1a04d035 A |
47 | |
48 | # First we create a file | |
1ae6ead9 | 49 | open(F, ">", "file-$$") or die $!; |
1a04d035 | 50 | binmode F; # for DOSISH platforms, because test 3 copies to stdout |
83519ebf | 51 | printf F "ok\n"; |
1a04d035 A |
52 | close F; |
53 | ||
54 | copy "file-$$", "copy-$$"; | |
55 | ||
1ae6ead9 | 56 | open(F, "<", "copy-$$") or die $!; |
81ec4fbc | 57 | my $foo = <F>; |
1a04d035 A |
58 | close(F); |
59 | ||
96fe83cd | 60 | is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; |
1a04d035 | 61 | |
96fe83cd | 62 | is $foo, "ok\n", 'copy(fn, fn): same contents'; |
1a04d035 | 63 | |
96fe83cd | 64 | print("# next test checks copying to STDOUT\n"); |
1a04d035 | 65 | binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode |
83519ebf | 66 | # This outputs "ok" so its a test. |
1a04d035 | 67 | copy "copy-$$", \*STDOUT; |
83519ebf | 68 | $TB->current_test($TB->current_test + 1); |
1a04d035 A |
69 | unlink "copy-$$" or die "unlink: $!"; |
70 | ||
1ae6ead9 | 71 | open(F, "<", "file-$$"); |
e91a8fe5 | 72 | binmode F; |
1a04d035 | 73 | copy(*F, "copy-$$"); |
e91a8fe5 | 74 | open(R, "<:raw", "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); |
96fe83cd | 75 | is $foo, "ok\n", 'copy(*F, fn): same contents'; |
1a04d035 | 76 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf | 77 | |
1ae6ead9 | 78 | open(F, "<", "file-$$"); |
e91a8fe5 | 79 | binmode F; |
1a04d035 A |
80 | copy(\*F, "copy-$$"); |
81 | close(F) or die "close: $!"; | |
1ae6ead9 | 82 | open(R, "<", "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; |
96fe83cd | 83 | is $foo, "ok\n", 'copy(\*F, fn): same contents'; |
1a04d035 A |
84 | unlink "copy-$$" or die "unlink: $!"; |
85 | ||
86 | require IO::File; | |
81ec4fbc | 87 | my $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
671637fe | 88 | binmode $fh or die $!; |
1a04d035 A |
89 | copy("file-$$",$fh); |
90 | $fh->close or die "close: $!"; | |
1ae6ead9 | 91 | open(R, "<", "copy-$$") or die; $foo = <R>; close(R); |
96fe83cd | 92 | is $foo, "ok\n", 'copy(fn, io): same contents'; |
1a04d035 | 93 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf | 94 | |
1a04d035 | 95 | require FileHandle; |
81ec4fbc | 96 | $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
671637fe | 97 | binmode $fh or die $!; |
1a04d035 A |
98 | copy("file-$$",$fh); |
99 | $fh->close; | |
1ae6ead9 | 100 | open(R, "<", "copy-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 101 | is $foo, "ok\n", 'copy(fn, fh): same contents'; |
1a04d035 A |
102 | unlink "file-$$" or die "unlink: $!"; |
103 | ||
83519ebf MS |
104 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
105 | ok -e "copy-$$", ' target still there'; | |
1a04d035 | 106 | |
1ef59467 | 107 | # Doesn't really matter what time it is as long as its not now. |
310d0155 | 108 | my $time = 1000000000.12345; |
1ef59467 MS |
109 | utime( $time, $time, "copy-$$" ); |
110 | ||
111 | # Recheck the mtime rather than rely on utime in case we're on a | |
112 | # system where utime doesn't work or there's no mtime at all. | |
113 | # The destination file will reflect the same difficulties. | |
114 | my $mtime = (stat("copy-$$"))[9]; | |
115 | ||
754f2cd0 | 116 | ok move("copy-$$", "file-$$"), 'move'; |
83519ebf MS |
117 | ok -e "file-$$", ' destination exists'; |
118 | ok !-e "copy-$$", ' source does not'; | |
1ae6ead9 | 119 | open(R, "<", "file-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 120 | is $foo, "ok\n", 'contents preserved'; |
83519ebf | 121 | |
e9e3be28 CB |
122 | TODO: { |
123 | local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS'; | |
124 | ||
125 | my $dest_mtime = (stat("file-$$"))[9]; | |
126 | is $dest_mtime, $mtime, | |
127 | "mtime preserved by copy()". | |
128 | ($cross_partition_test ? " while testing cross-partition" : ""); | |
129 | } | |
1ef59467 | 130 | |
96fe83cd | 131 | # trick: create lib/ if not exists - not needed in Perl core |
671637fe | 132 | unless (-d 'lib') { mkdir 'lib' or die $!; } |
83519ebf | 133 | copy "file-$$", "lib"; |
1ae6ead9 | 134 | open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 135 | is $foo, "ok\n", 'copy(fn, dir): same contents'; |
83519ebf MS |
136 | unlink "lib/file-$$" or die "unlink: $!"; |
137 | ||
138 | # Do it twice to ensure copying over the same file works. | |
139 | copy "file-$$", "lib"; | |
1ae6ead9 | 140 | open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); |
96fe83cd | 141 | is $foo, "ok\n", 'copy over the same file works'; |
83519ebf MS |
142 | unlink "lib/file-$$" or die "unlink: $!"; |
143 | ||
754f2cd0 MS |
144 | { |
145 | my $warnings = ''; | |
146 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
39b80fd9 | 147 | ok !copy("file-$$", "file-$$"), 'copy to itself fails'; |
754f2cd0 | 148 | |
96fe83cd AF |
149 | like $warnings, qr/are identical/, 'but warns'; |
150 | ok -s "file-$$", 'contents preserved'; | |
754f2cd0 | 151 | } |
83519ebf MS |
152 | |
153 | move "file-$$", "lib"; | |
1ae6ead9 | 154 | open(R, "<", "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); |
96fe83cd AF |
155 | is $foo, "ok\n", 'move(fn, dir): same contents'; |
156 | ok !-e "file-$$", 'file moved indeed'; | |
83519ebf MS |
157 | unlink "lib/file-$$" or die "unlink: $!"; |
158 | ||
159 | SKIP: { | |
754f2cd0 | 160 | skip "Testing symlinks", 3 unless $Config{d_symlink}; |
ac7b122d | 161 | |
1ae6ead9 | 162 | open(F, ">", "file-$$") or die $!; |
ac7b122d SR |
163 | print F "dummy content\n"; |
164 | close F; | |
520fd6d3 TC |
165 | if (!symlink("file-$$", "symlink-$$")) { |
166 | unlink "file-$$"; | |
167 | skip "Can't create symlink", 3; | |
168 | } | |
754f2cd0 MS |
169 | |
170 | my $warnings = ''; | |
171 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
96fe83cd | 172 | ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; |
754f2cd0 | 173 | |
96fe83cd | 174 | like $warnings, qr/are identical/, 'emits a warning'; |
83519ebf MS |
175 | ok !-z "file-$$", |
176 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
177 | ||
671637fe NC |
178 | unlink "symlink-$$" or die $!; |
179 | unlink "file-$$" or die $!; | |
6c254d95 | 180 | } |
ac7b122d | 181 | |
83519ebf | 182 | SKIP: { |
96fe83cd AF |
183 | skip "Testing hard links", 3 |
184 | if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; | |
83519ebf | 185 | |
1ae6ead9 | 186 | open(F, ">", "file-$$") or die $!; |
83519ebf MS |
187 | print F "dummy content\n"; |
188 | close F; | |
189 | link("file-$$", "hardlink-$$") or die $!; | |
754f2cd0 MS |
190 | |
191 | my $warnings = ''; | |
192 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
96fe83cd | 193 | ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; |
754f2cd0 | 194 | |
96fe83cd | 195 | like $warnings, qr/are identical/, 'emits a warning'; |
83519ebf MS |
196 | ok ! -z "file-$$", |
197 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
198 | ||
671637fe NC |
199 | unlink "hardlink-$$" or die $!; |
200 | unlink "file-$$" or die $!; | |
ac7b122d | 201 | } |
671637fe | 202 | |
1ae6ead9 | 203 | open(F, ">", "file-$$") or die $!; |
671637fe NC |
204 | binmode F; |
205 | print F "this is file\n"; | |
206 | close F; | |
207 | ||
208 | my $copy_msg = "this is copy\n"; | |
1ae6ead9 | 209 | open(F, ">", "copy-$$") or die $!; |
671637fe NC |
210 | binmode F; |
211 | print F $copy_msg; | |
212 | close F; | |
213 | ||
214 | my @warnings; | |
215 | local $SIG{__WARN__} = sub { push @warnings, join '', @_ }; | |
216 | ||
217 | # pie-$$ so that we force a non-constant, else the numeric conversion (of 0) | |
bd86609c | 218 | # is cached and we do not get a warning the second time round |
671637fe NC |
219 | is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef, |
220 | "a bad buffer size fails to copy"; | |
221 | like $@, qr/Bad buffer size for copy/, "with a helpful error message"; | |
222 | unless (is scalar @warnings, 1, "There is 1 warning") { | |
223 | diag $_ foreach @warnings; | |
224 | } | |
225 | ||
226 | is -s "copy-$$", length $copy_msg, "but does not truncate the destination"; | |
1ae6ead9 | 227 | open(F, "<", "copy-$$") or die $!; |
671637fe NC |
228 | $foo = <F>; |
229 | close(F); | |
230 | is $foo, $copy_msg, "nor change the destination's contents"; | |
231 | ||
232 | unlink "file-$$" or die $!; | |
233 | unlink "copy-$$" or die $!; | |
fff5c6e2 DM |
234 | |
235 | # RT #73714 copy to file with leading whitespace failed | |
236 | ||
69a90d4d CB |
237 | TODO: { |
238 | local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS'; | |
1ae6ead9 | 239 | open(F, ">", "file-$$") or die $!; |
fff5c6e2 DM |
240 | close F; |
241 | copy "file-$$", " copy-$$"; | |
fff5c6e2 DM |
242 | ok -e " copy-$$", "copy with leading whitespace"; |
243 | unlink "file-$$" or die "unlink: $!"; | |
244 | unlink " copy-$$" or die "unlink: $!"; | |
69a90d4d | 245 | } |
1a04d035 A |
246 | } |
247 | ||
cae9400f AB |
248 | my $can_suidp = sub { |
249 | my $dir = "suid-$$"; | |
250 | my $ok = 1; | |
251 | mkdir $dir or die "Can't mkdir($dir) for suid test"; | |
252 | $ok = 0 unless chmod 2000, $dir; | |
253 | rmdir $dir; | |
254 | return $ok; | |
255 | }; | |
441496b2 | 256 | |
32d68040 | 257 | SKIP: { |
20513930 A |
258 | my @tests = ( |
259 | [0000, 0777, 0777, 0777], | |
260 | [0000, 0751, 0751, 0644], | |
261 | [0022, 0777, 0755, 0206], | |
262 | [0022, 0415, 0415, 0666], | |
263 | [0077, 0777, 0700, 0333], | |
264 | [0027, 0755, 0750, 0251], | |
265 | [0777, 0751, 0000, 0215], | |
266 | ); | |
267 | ||
268 | my $skips = @tests * 6 * 8; | |
32d68040 | 269 | |
cae9400f AB |
270 | my $can_suid = $can_suidp->(); |
271 | skip "Can't suid on this $^O filesystem", $skips unless $can_suid; | |
20513930 A |
272 | skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips |
273 | if $^O eq 'VMS'; | |
274 | skip "Copy doesn't set file permissions correctly on Win32.", $skips | |
275 | if $^O eq "MSWin32"; | |
f6dacdca PG |
276 | skip "Copy maps POSIX permissions to VOS permissions.", $skips |
277 | if $^O eq "vos"; | |
33821f2f CBW |
278 | skip "There be dragons here with DragonflyBSD.", $skips |
279 | if $^O eq 'dragonfly'; | |
280 | ||
32d68040 | 281 | |
81ec4fbc A |
282 | # Just a sub to get better failure messages. |
283 | sub __ ($) { | |
20513930 A |
284 | my $perm = shift; |
285 | my $id = 07000 & $perm; | |
286 | $id >>= 9; | |
287 | $perm &= 0777; | |
288 | my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} | |
289 | split // => sprintf "%03o" => $perm; | |
290 | if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} | |
291 | if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} | |
292 | if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} | |
293 | join "" => @chunks; | |
81ec4fbc A |
294 | } |
295 | # Testing permission bits. | |
296 | my $src = "file-$$"; | |
297 | my $copy1 = "copy1-$$"; | |
298 | my $copy2 = "copy2-$$"; | |
299 | my $copy3 = "copy3-$$"; | |
e63b3379 CB |
300 | my $copy4 = "copy4-$$"; |
301 | my $copy5 = "copy5-$$"; | |
302 | my $copy6 = "copy6-$$"; | |
c1976a97 | 303 | my $copyd = "copyd-$$"; |
81ec4fbc A |
304 | |
305 | open my $fh => ">", $src or die $!; | |
306 | close $fh or die $!; | |
307 | ||
308 | open $fh => ">", $copy3 or die $!; | |
309 | close $fh or die $!; | |
310 | ||
e63b3379 CB |
311 | open $fh => ">", $copy6 or die $!; |
312 | close $fh or die $!; | |
313 | ||
81ec4fbc A |
314 | my $old_mask = umask; |
315 | foreach my $test (@tests) { | |
20513930 A |
316 | foreach my $id (0 .. 7) { |
317 | my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; | |
bd86609c | 318 | # Make sure the copies do not exist. |
20513930 A |
319 | ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; |
320 | ||
321 | $s_perm |= $id << 9; | |
322 | $c_perm1 |= $id << 9; | |
b1144eba JH |
323 | diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) |
324 | unless ($ENV{PERL_CORE}); | |
76073986 NC |
325 | |
326 | # Test that we can actually set a file to the correct permission. | |
327 | # Slightly convoluted, because some operating systems will let us | |
328 | # set a directory, but not a file. These should all work: | |
c1976a97 TC |
329 | mkdir $copyd or die "Can't mkdir $copyd: $!"; |
330 | chmod $s_perm, $copyd | |
331 | or die sprintf "Can't chmod %o $copyd: $!", $s_perm; | |
332 | rmdir $copyd | |
333 | or die sprintf "Can't rmdir $copyd: $!"; | |
76073986 NC |
334 | open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; |
335 | close $fh0 or die "Can't close $copy1: $!"; | |
336 | unless (chmod $s_perm, $copy1) { | |
337 | $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) | |
338 | for 1..6; | |
339 | next; | |
340 | } | |
341 | my $perm0 = (stat $copy1) [2] & 07777; | |
342 | unless ($perm0 == $s_perm) { | |
343 | $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", | |
344 | $s_perm, $perm0) | |
345 | for 1..6; | |
346 | next; | |
347 | } | |
348 | unlink $copy1 or die "Can't unlink $copy1: $!"; | |
349 | ||
20513930 A |
350 | (umask $umask) // die $!; |
351 | chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; | |
352 | chmod $c_perm3 => $copy3 or die $!; | |
353 | chmod $c_perm3 => $copy6 or die $!; | |
354 | ||
355 | open my $fh => "<", $src or die $!; | |
e91a8fe5 | 356 | binmode $fh; |
20513930 A |
357 | |
358 | copy ($src, $copy1); | |
359 | copy ($fh, $copy2); | |
360 | copy ($src, $copy3); | |
361 | cp ($src, $copy4); | |
362 | cp ($fh, $copy5); | |
363 | cp ($src, $copy6); | |
364 | ||
365 | my $permdef = 0666 & ~$umask; | |
366 | my $perm1 = (stat $copy1) [2] & 07777; | |
367 | my $perm2 = (stat $copy2) [2] & 07777; | |
368 | my $perm3 = (stat $copy3) [2] & 07777; | |
369 | my $perm4 = (stat $copy4) [2] & 07777; | |
370 | my $perm5 = (stat $copy5) [2] & 07777; | |
371 | my $perm6 = (stat $copy6) [2] & 07777; | |
372 | is (__$perm1, __$permdef, "Permission bits set correctly"); | |
373 | is (__$perm2, __$permdef, "Permission bits set correctly"); | |
374 | is (__$perm4, __$c_perm1, "Permission bits set correctly"); | |
375 | is (__$perm5, __$c_perm1, "Permission bits set correctly"); | |
f095462e TC |
376 | is (__$perm3, __$c_perm3, "Permission bits not modified"); |
377 | is (__$perm6, __$c_perm3, "Permission bits not modified"); | |
c4e1003e | 378 | } |
81ec4fbc A |
379 | } |
380 | umask $old_mask or die $!; | |
381 | ||
382 | # Clean up. | |
20513930 A |
383 | ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, |
384 | $copy4, $copy5, $copy6; | |
81ec4fbc A |
385 | } |
386 | ||
e55c0a82 PR |
387 | { |
388 | package Crash; | |
389 | # a package overloaded suspiciously like IO::Scalar | |
390 | use overload '""' => sub { ${$_[0]} }; | |
391 | use overload 'bool' => sub { 1 }; | |
392 | sub new { | |
393 | my ($class, $name) = @_; | |
394 | bless \$name, $class; | |
395 | } | |
396 | ||
397 | package Zowie; | |
398 | # a different package overloaded suspiciously like IO::Scalar | |
399 | use overload '""' => sub { ${$_[0]} }; | |
400 | use overload 'bool' => sub { 1 }; | |
401 | sub new { | |
402 | my ($class, $name) = @_; | |
403 | bless \$name, $class; | |
404 | } | |
405 | } | |
406 | { | |
407 | my $object = Crash->new('whack_eth'); | |
408 | my %what = (plain => "$object", | |
409 | object1 => $object, | |
410 | object2 => Zowie->new('whack_eth'), | |
411 | object2 => Zowie->new('whack_eth'), | |
412 | ); | |
413 | ||
414 | my @warnings; | |
415 | local $SIG{__WARN__} = sub { | |
416 | push @warnings, @_; | |
417 | }; | |
418 | ||
419 | foreach my $left (qw(plain object1 object2)) { | |
420 | foreach my $right (qw(plain object1 object2)) { | |
421 | @warnings = (); | |
422 | $! = 0; | |
39b80fd9 | 423 | is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right"; |
e55c0a82 PR |
424 | is $@, '', 'No croaking'; |
425 | is $!, '', 'No system call errors'; | |
426 | is @warnings, 1, 'Exactly 1 warning'; | |
427 | like $warnings[0], | |
428 | qr/'$object' and '$object' are identical \(not copied\)/, | |
429 | 'with the text we expect'; | |
430 | } | |
431 | } | |
432 | } | |
81ec4fbc | 433 | |
079cb8cc PF |
434 | # On Unix systems, File::Copy always returns 0 to signal failure, |
435 | # even when in list context! On Windows, it always returns "" to signal | |
436 | # failure. | |
437 | # | |
438 | # While returning a list containing a false value is arguably a bad | |
439 | # API design, at the very least we can make sure it always returns | |
440 | # the same false value. | |
441 | ||
442 | my $NO_SUCH_FILE = "this_file_had_better_not_exist"; | |
443 | my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; | |
444 | ||
445 | use constant EXPECTED_SCALAR => 0; | |
446 | use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; | |
447 | ||
448 | my %subs = ( | |
449 | copy => \&File::Copy::copy, | |
450 | cp => \&File::Copy::cp, | |
451 | move => \&File::Copy::move, | |
452 | mv => \&File::Copy::mv, | |
453 | ); | |
454 | ||
455 | SKIP: { | |
456 | skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) | |
457 | if (-e $NO_SUCH_FILE); | |
458 | ||
459 | foreach my $name (keys %subs) { | |
460 | ||
461 | my $sub = $subs{$name}; | |
462 | ||
463 | my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); | |
464 | is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); | |
465 | ||
466 | my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); | |
467 | is_deeply( \@array, EXPECTED_LIST, "$name in list context"); | |
468 | } | |
469 | } | |
470 | ||
16f708c9 NT |
471 | SKIP: { |
472 | skip("fork required to test pipe copying", 2) | |
473 | if (!$Config{'d_fork'}); | |
474 | ||
475 | open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; | |
476 | open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; | |
e91a8fe5 TC |
477 | binmode $IN; |
478 | binmode $OUT; | |
16f708c9 NT |
479 | |
480 | ok(copy($IN, $OUT), "copy pipe to another"); | |
481 | close($OUT); | |
482 | is($? >> 8, 55, "content copied through the pipes"); | |
483 | close($IN); | |
484 | } | |
485 | ||
b306ad7b TC |
486 | use File::Temp qw(tempdir); |
487 | use File::Spec; | |
488 | ||
489 | SKIP: { | |
b306ad7b TC |
490 | # RT #111126: File::Copy copy() zeros file when copying a file |
491 | # into the same directory it is stored in | |
492 | ||
493 | my $temp_dir = tempdir( CLEANUP => 1 ); | |
494 | my $temp_file = File::Spec->catfile($temp_dir, "somefile"); | |
495 | ||
496 | open my $fh, ">", $temp_file | |
497 | or skip "Cannot create $temp_file: $!", 2; | |
498 | print $fh "Just some data"; | |
499 | close $fh | |
500 | or skip "Cannot close $temp_file: $!", 2; | |
501 | ||
502 | my $warn_message = ""; | |
503 | local $SIG{__WARN__} = sub { $warn_message .= "@_" }; | |
504 | ok(!copy($temp_file, $temp_dir), | |
505 | "Copy of foo/file to foo/ should fail"); | |
c83aeb21 | 506 | like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i, |
b306ad7b TC |
507 | "error message should describe the problem"); |
508 | 1 while unlink $temp_file; | |
509 | } | |
510 | ||
bd86609c JK |
511 | { |
512 | open(my $F, '>', "file-$$") or die $!; | |
513 | binmode $F; # for DOSISH platforms | |
514 | printf $F "ok\n"; | |
515 | close $F; | |
516 | ||
517 | my $buffer = (1024 * 1024 * 2) + 1; | |
518 | is eval {copy "file-$$", "copy-$$", $buffer}, 1, | |
519 | "copy with buffer above normal size"; | |
520 | } | |
521 | ||
70cbce25 | 522 | done_testing(); |
bd86609c | 523 | |
cfcb0b09 | 524 | END { |
bd86609c | 525 | 1 while unlink "copy-$$"; |
cfcb0b09 | 526 | 1 while unlink "file-$$"; |
83519ebf | 527 | 1 while unlink "lib/file-$$"; |
cfcb0b09 | 528 | } |