| 1 | #!./perl -w |
| 2 | |
| 3 | BEGIN { |
| 4 | if( $ENV{PERL_CORE} ) { |
| 5 | chdir 't' if -d 't'; |
| 6 | @INC = '../lib'; |
| 7 | } |
| 8 | } |
| 9 | |
| 10 | use strict; |
| 11 | use warnings; |
| 12 | |
| 13 | use Test::More; |
| 14 | |
| 15 | my $TB = Test::More->builder; |
| 16 | |
| 17 | plan tests => 466; |
| 18 | |
| 19 | # We are 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 | |
| 23 | |
| 24 | use File::Copy qw(copy move cp); |
| 25 | use Config; |
| 26 | |
| 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; |
| 33 | like $@, qr/^Usage: /, "'$code' is a usage error"; |
| 34 | } |
| 35 | |
| 36 | |
| 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 | } |
| 44 | |
| 45 | # First we create a file |
| 46 | open(F, ">", "file-$$") or die $!; |
| 47 | binmode F; # for DOSISH platforms, because test 3 copies to stdout |
| 48 | printf F "ok\n"; |
| 49 | close F; |
| 50 | |
| 51 | copy "file-$$", "copy-$$"; |
| 52 | |
| 53 | open(F, "<", "copy-$$") or die $!; |
| 54 | my $foo = <F>; |
| 55 | close(F); |
| 56 | |
| 57 | is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; |
| 58 | |
| 59 | is $foo, "ok\n", 'copy(fn, fn): same contents'; |
| 60 | |
| 61 | print("# next test checks copying to STDOUT\n"); |
| 62 | binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode |
| 63 | # This outputs "ok" so its a test. |
| 64 | copy "copy-$$", \*STDOUT; |
| 65 | $TB->current_test($TB->current_test + 1); |
| 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); |
| 71 | is $foo, "ok\n", 'copy(*F, fn): same contents'; |
| 72 | unlink "copy-$$" or die "unlink: $!"; |
| 73 | |
| 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: $!"; |
| 78 | is $foo, "ok\n", 'copy(\*F, fn): same contents'; |
| 79 | unlink "copy-$$" or die "unlink: $!"; |
| 80 | |
| 81 | require IO::File; |
| 82 | my $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
| 83 | binmode $fh or die $!; |
| 84 | copy("file-$$",$fh); |
| 85 | $fh->close or die "close: $!"; |
| 86 | open(R, "<", "copy-$$") or die; $foo = <R>; close(R); |
| 87 | is $foo, "ok\n", 'copy(fn, io): same contents'; |
| 88 | unlink "copy-$$" or die "unlink: $!"; |
| 89 | |
| 90 | require FileHandle; |
| 91 | $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
| 92 | binmode $fh or die $!; |
| 93 | copy("file-$$",$fh); |
| 94 | $fh->close; |
| 95 | open(R, "<", "copy-$$") or die $!; $foo = <R>; close(R); |
| 96 | is $foo, "ok\n", 'copy(fn, fh): same contents'; |
| 97 | unlink "file-$$" or die "unlink: $!"; |
| 98 | |
| 99 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
| 100 | ok -e "copy-$$", ' target still there'; |
| 101 | |
| 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 | |
| 111 | ok move("copy-$$", "file-$$"), 'move'; |
| 112 | ok -e "file-$$", ' destination exists'; |
| 113 | ok !-e "copy-$$", ' source does not'; |
| 114 | open(R, "<", "file-$$") or die $!; $foo = <R>; close(R); |
| 115 | is $foo, "ok\n", 'contents preserved'; |
| 116 | |
| 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 | } |
| 125 | |
| 126 | # trick: create lib/ if not exists - not needed in Perl core |
| 127 | unless (-d 'lib') { mkdir 'lib' or die $!; } |
| 128 | copy "file-$$", "lib"; |
| 129 | open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); |
| 130 | is $foo, "ok\n", 'copy(fn, dir): same contents'; |
| 131 | unlink "lib/file-$$" or die "unlink: $!"; |
| 132 | |
| 133 | # Do it twice to ensure copying over the same file works. |
| 134 | copy "file-$$", "lib"; |
| 135 | open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); |
| 136 | is $foo, "ok\n", 'copy over the same file works'; |
| 137 | unlink "lib/file-$$" or die "unlink: $!"; |
| 138 | |
| 139 | { |
| 140 | my $warnings = ''; |
| 141 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; |
| 142 | ok !copy("file-$$", "file-$$"), 'copy to itself fails'; |
| 143 | |
| 144 | like $warnings, qr/are identical/, 'but warns'; |
| 145 | ok -s "file-$$", 'contents preserved'; |
| 146 | } |
| 147 | |
| 148 | move "file-$$", "lib"; |
| 149 | open(R, "<", "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); |
| 150 | is $foo, "ok\n", 'move(fn, dir): same contents'; |
| 151 | ok !-e "file-$$", 'file moved indeed'; |
| 152 | unlink "lib/file-$$" or die "unlink: $!"; |
| 153 | |
| 154 | SKIP: { |
| 155 | skip "Testing symlinks", 3 unless $Config{d_symlink}; |
| 156 | |
| 157 | open(F, ">", "file-$$") or die $!; |
| 158 | print F "dummy content\n"; |
| 159 | close F; |
| 160 | symlink("file-$$", "symlink-$$") or die $!; |
| 161 | |
| 162 | my $warnings = ''; |
| 163 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; |
| 164 | ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; |
| 165 | |
| 166 | like $warnings, qr/are identical/, 'emits a warning'; |
| 167 | ok !-z "file-$$", |
| 168 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
| 169 | |
| 170 | unlink "symlink-$$" or die $!; |
| 171 | unlink "file-$$" or die $!; |
| 172 | } |
| 173 | |
| 174 | SKIP: { |
| 175 | skip "Testing hard links", 3 |
| 176 | if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; |
| 177 | |
| 178 | open(F, ">", "file-$$") or die $!; |
| 179 | print F "dummy content\n"; |
| 180 | close F; |
| 181 | link("file-$$", "hardlink-$$") or die $!; |
| 182 | |
| 183 | my $warnings = ''; |
| 184 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; |
| 185 | ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; |
| 186 | |
| 187 | like $warnings, qr/are identical/, 'emits a warning'; |
| 188 | ok ! -z "file-$$", |
| 189 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
| 190 | |
| 191 | unlink "hardlink-$$" or die $!; |
| 192 | unlink "file-$$" or die $!; |
| 193 | } |
| 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 do not 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 $!; |
| 226 | |
| 227 | # RT #73714 copy to file with leading whitespace failed |
| 228 | |
| 229 | TODO: { |
| 230 | local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS'; |
| 231 | open(F, ">", "file-$$") or die $!; |
| 232 | close F; |
| 233 | copy "file-$$", " copy-$$"; |
| 234 | ok -e " copy-$$", "copy with leading whitespace"; |
| 235 | unlink "file-$$" or die "unlink: $!"; |
| 236 | unlink " copy-$$" or die "unlink: $!"; |
| 237 | } |
| 238 | } |
| 239 | |
| 240 | my $can_suidp = sub { |
| 241 | my $dir = "suid-$$"; |
| 242 | my $ok = 1; |
| 243 | mkdir $dir or die "Can't mkdir($dir) for suid test"; |
| 244 | $ok = 0 unless chmod 2000, $dir; |
| 245 | rmdir $dir; |
| 246 | return $ok; |
| 247 | }; |
| 248 | |
| 249 | SKIP: { |
| 250 | my @tests = ( |
| 251 | [0000, 0777, 0777, 0777], |
| 252 | [0000, 0751, 0751, 0644], |
| 253 | [0022, 0777, 0755, 0206], |
| 254 | [0022, 0415, 0415, 0666], |
| 255 | [0077, 0777, 0700, 0333], |
| 256 | [0027, 0755, 0750, 0251], |
| 257 | [0777, 0751, 0000, 0215], |
| 258 | ); |
| 259 | |
| 260 | my $skips = @tests * 6 * 8; |
| 261 | |
| 262 | my $can_suid = $can_suidp->(); |
| 263 | skip "Can't suid on this $^O filesystem", $skips unless $can_suid; |
| 264 | skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips |
| 265 | if $^O eq 'VMS'; |
| 266 | skip "Copy doesn't set file permissions correctly on Win32.", $skips |
| 267 | if $^O eq "MSWin32"; |
| 268 | skip "Copy maps POSIX permissions to VOS permissions.", $skips |
| 269 | if $^O eq "vos"; |
| 270 | skip "There be dragons here with DragonflyBSD.", $skips |
| 271 | if $^O eq 'dragonfly'; |
| 272 | |
| 273 | |
| 274 | # Just a sub to get better failure messages. |
| 275 | sub __ ($) { |
| 276 | my $perm = shift; |
| 277 | my $id = 07000 & $perm; |
| 278 | $id >>= 9; |
| 279 | $perm &= 0777; |
| 280 | my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} |
| 281 | split // => sprintf "%03o" => $perm; |
| 282 | if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} |
| 283 | if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} |
| 284 | if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} |
| 285 | join "" => @chunks; |
| 286 | } |
| 287 | # Testing permission bits. |
| 288 | my $src = "file-$$"; |
| 289 | my $copy1 = "copy1-$$"; |
| 290 | my $copy2 = "copy2-$$"; |
| 291 | my $copy3 = "copy3-$$"; |
| 292 | my $copy4 = "copy4-$$"; |
| 293 | my $copy5 = "copy5-$$"; |
| 294 | my $copy6 = "copy6-$$"; |
| 295 | my $copyd = "copyd-$$"; |
| 296 | |
| 297 | open my $fh => ">", $src or die $!; |
| 298 | close $fh or die $!; |
| 299 | |
| 300 | open $fh => ">", $copy3 or die $!; |
| 301 | close $fh or die $!; |
| 302 | |
| 303 | open $fh => ">", $copy6 or die $!; |
| 304 | close $fh or die $!; |
| 305 | |
| 306 | my $old_mask = umask; |
| 307 | foreach my $test (@tests) { |
| 308 | foreach my $id (0 .. 7) { |
| 309 | my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; |
| 310 | # Make sure the copies do not exist. |
| 311 | ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; |
| 312 | |
| 313 | $s_perm |= $id << 9; |
| 314 | $c_perm1 |= $id << 9; |
| 315 | diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) |
| 316 | unless ($ENV{PERL_CORE}); |
| 317 | |
| 318 | # Test that we can actually set a file to the correct permission. |
| 319 | # Slightly convoluted, because some operating systems will let us |
| 320 | # set a directory, but not a file. These should all work: |
| 321 | mkdir $copyd or die "Can't mkdir $copyd: $!"; |
| 322 | chmod $s_perm, $copyd |
| 323 | or die sprintf "Can't chmod %o $copyd: $!", $s_perm; |
| 324 | rmdir $copyd |
| 325 | or die sprintf "Can't rmdir $copyd: $!"; |
| 326 | open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; |
| 327 | close $fh0 or die "Can't close $copy1: $!"; |
| 328 | unless (chmod $s_perm, $copy1) { |
| 329 | $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) |
| 330 | for 1..6; |
| 331 | next; |
| 332 | } |
| 333 | my $perm0 = (stat $copy1) [2] & 07777; |
| 334 | unless ($perm0 == $s_perm) { |
| 335 | $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", |
| 336 | $s_perm, $perm0) |
| 337 | for 1..6; |
| 338 | next; |
| 339 | } |
| 340 | unlink $copy1 or die "Can't unlink $copy1: $!"; |
| 341 | |
| 342 | (umask $umask) // die $!; |
| 343 | chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; |
| 344 | chmod $c_perm3 => $copy3 or die $!; |
| 345 | chmod $c_perm3 => $copy6 or die $!; |
| 346 | |
| 347 | open my $fh => "<", $src or die $!; |
| 348 | |
| 349 | copy ($src, $copy1); |
| 350 | copy ($fh, $copy2); |
| 351 | copy ($src, $copy3); |
| 352 | cp ($src, $copy4); |
| 353 | cp ($fh, $copy5); |
| 354 | cp ($src, $copy6); |
| 355 | |
| 356 | my $permdef = 0666 & ~$umask; |
| 357 | my $perm1 = (stat $copy1) [2] & 07777; |
| 358 | my $perm2 = (stat $copy2) [2] & 07777; |
| 359 | my $perm3 = (stat $copy3) [2] & 07777; |
| 360 | my $perm4 = (stat $copy4) [2] & 07777; |
| 361 | my $perm5 = (stat $copy5) [2] & 07777; |
| 362 | my $perm6 = (stat $copy6) [2] & 07777; |
| 363 | is (__$perm1, __$permdef, "Permission bits set correctly"); |
| 364 | is (__$perm2, __$permdef, "Permission bits set correctly"); |
| 365 | is (__$perm4, __$c_perm1, "Permission bits set correctly"); |
| 366 | is (__$perm5, __$c_perm1, "Permission bits set correctly"); |
| 367 | is (__$perm3, __$c_perm3, "Permission bits not modified"); |
| 368 | is (__$perm6, __$c_perm3, "Permission bits not modified"); |
| 369 | } |
| 370 | } |
| 371 | umask $old_mask or die $!; |
| 372 | |
| 373 | # Clean up. |
| 374 | ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, |
| 375 | $copy4, $copy5, $copy6; |
| 376 | } |
| 377 | |
| 378 | { |
| 379 | package Crash; |
| 380 | # a 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 | package Zowie; |
| 389 | # a different 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 | { |
| 398 | my $object = Crash->new('whack_eth'); |
| 399 | my %what = (plain => "$object", |
| 400 | object1 => $object, |
| 401 | object2 => Zowie->new('whack_eth'), |
| 402 | object2 => Zowie->new('whack_eth'), |
| 403 | ); |
| 404 | |
| 405 | my @warnings; |
| 406 | local $SIG{__WARN__} = sub { |
| 407 | push @warnings, @_; |
| 408 | }; |
| 409 | |
| 410 | foreach my $left (qw(plain object1 object2)) { |
| 411 | foreach my $right (qw(plain object1 object2)) { |
| 412 | @warnings = (); |
| 413 | $! = 0; |
| 414 | is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right"; |
| 415 | is $@, '', 'No croaking'; |
| 416 | is $!, '', 'No system call errors'; |
| 417 | is @warnings, 1, 'Exactly 1 warning'; |
| 418 | like $warnings[0], |
| 419 | qr/'$object' and '$object' are identical \(not copied\)/, |
| 420 | 'with the text we expect'; |
| 421 | } |
| 422 | } |
| 423 | } |
| 424 | |
| 425 | # On Unix systems, File::Copy always returns 0 to signal failure, |
| 426 | # even when in list context! On Windows, it always returns "" to signal |
| 427 | # failure. |
| 428 | # |
| 429 | # While returning a list containing a false value is arguably a bad |
| 430 | # API design, at the very least we can make sure it always returns |
| 431 | # the same false value. |
| 432 | |
| 433 | my $NO_SUCH_FILE = "this_file_had_better_not_exist"; |
| 434 | my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; |
| 435 | |
| 436 | use constant EXPECTED_SCALAR => 0; |
| 437 | use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; |
| 438 | |
| 439 | my %subs = ( |
| 440 | copy => \&File::Copy::copy, |
| 441 | cp => \&File::Copy::cp, |
| 442 | move => \&File::Copy::move, |
| 443 | mv => \&File::Copy::mv, |
| 444 | ); |
| 445 | |
| 446 | SKIP: { |
| 447 | skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) |
| 448 | if (-e $NO_SUCH_FILE); |
| 449 | |
| 450 | foreach my $name (keys %subs) { |
| 451 | |
| 452 | my $sub = $subs{$name}; |
| 453 | |
| 454 | my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); |
| 455 | is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); |
| 456 | |
| 457 | my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); |
| 458 | is_deeply( \@array, EXPECTED_LIST, "$name in list context"); |
| 459 | } |
| 460 | } |
| 461 | |
| 462 | SKIP: { |
| 463 | skip("fork required to test pipe copying", 2) |
| 464 | if (!$Config{'d_fork'}); |
| 465 | |
| 466 | open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; |
| 467 | open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; |
| 468 | |
| 469 | ok(copy($IN, $OUT), "copy pipe to another"); |
| 470 | close($OUT); |
| 471 | is($? >> 8, 55, "content copied through the pipes"); |
| 472 | close($IN); |
| 473 | } |
| 474 | |
| 475 | use File::Temp qw(tempdir); |
| 476 | use File::Spec; |
| 477 | |
| 478 | SKIP: { |
| 479 | # RT #111126: File::Copy copy() zeros file when copying a file |
| 480 | # into the same directory it is stored in |
| 481 | |
| 482 | my $temp_dir = tempdir( CLEANUP => 1 ); |
| 483 | my $temp_file = File::Spec->catfile($temp_dir, "somefile"); |
| 484 | |
| 485 | open my $fh, ">", $temp_file |
| 486 | or skip "Cannot create $temp_file: $!", 2; |
| 487 | print $fh "Just some data"; |
| 488 | close $fh |
| 489 | or skip "Cannot close $temp_file: $!", 2; |
| 490 | |
| 491 | my $warn_message = ""; |
| 492 | local $SIG{__WARN__} = sub { $warn_message .= "@_" }; |
| 493 | ok(!copy($temp_file, $temp_dir), |
| 494 | "Copy of foo/file to foo/ should fail"); |
| 495 | like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i, |
| 496 | "error message should describe the problem"); |
| 497 | 1 while unlink $temp_file; |
| 498 | } |
| 499 | |
| 500 | { |
| 501 | open(my $F, '>', "file-$$") or die $!; |
| 502 | binmode $F; # for DOSISH platforms |
| 503 | printf $F "ok\n"; |
| 504 | close $F; |
| 505 | |
| 506 | my $buffer = (1024 * 1024 * 2) + 1; |
| 507 | is eval {copy "file-$$", "copy-$$", $buffer}, 1, |
| 508 | "copy with buffer above normal size"; |
| 509 | } |
| 510 | |
| 511 | |
| 512 | END { |
| 513 | 1 while unlink "copy-$$"; |
| 514 | 1 while unlink "file-$$"; |
| 515 | 1 while unlink "lib/file-$$"; |
| 516 | } |