1#!./perl -w 2 3BEGIN { 4 if( $ENV{PERL_CORE} ) { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 } 8} 9 10use strict; 11use warnings; 12 13use Test::More; 14 15my $TB = Test::More->builder; 16 17# We are going to override rename() later on but Perl has to see an override 18# at compile time to honor it. 19BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; } 20 21 22use File::Copy qw(copy move cp); 23use Config; 24 25# If we have Time::HiRes, File::Copy loaded it for us. 26BEGIN { 27 eval { Time::HiRes->import(qw( stat utime )) }; 28 note "Testing Time::HiRes::utime support" unless $@; 29} 30 31foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')", 32 "move()", "move('arg')", "move('arg', 'arg', 'arg')" 33 ) 34{ 35 eval $code; 36 like $@, qr/^Usage: /, "'$code' is a usage error"; 37} 38 39 40for 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 } 47 48 # First we create a file 49 open(F, ">", "file-$$") or die $!; 50 binmode F; # for DOSISH platforms, because test 3 copies to stdout 51 printf F "ok\n"; 52 close F; 53 54 copy "file-$$", "copy-$$"; 55 56 open(F, "<", "copy-$$") or die $!; 57 my $foo = <F>; 58 close(F); 59 60 is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; 61 62 is $foo, "ok\n", 'copy(fn, fn): same contents'; 63 64 print("# next test checks copying to STDOUT\n"); 65 binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode 66 # This outputs "ok" so its a test. 67 copy "copy-$$", \*STDOUT; 68 $TB->current_test($TB->current_test + 1); 69 unlink "copy-$$" or die "unlink: $!"; 70 71 open(F, "<", "file-$$"); 72 binmode F; 73 copy(*F, "copy-$$"); 74 open(R, "<:raw", "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); 75 is $foo, "ok\n", 'copy(*F, fn): same contents'; 76 unlink "copy-$$" or die "unlink: $!"; 77 78 open(F, "<", "file-$$"); 79 binmode F; 80 copy(\*F, "copy-$$"); 81 close(F) or die "close: $!"; 82 open(R, "<", "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; 83 is $foo, "ok\n", 'copy(\*F, fn): same contents'; 84 unlink "copy-$$" or die "unlink: $!"; 85 86 require IO::File; 87 my $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; 88 binmode $fh or die $!; 89 copy("file-$$",$fh); 90 $fh->close or die "close: $!"; 91 open(R, "<", "copy-$$") or die; $foo = <R>; close(R); 92 is $foo, "ok\n", 'copy(fn, io): same contents'; 93 unlink "copy-$$" or die "unlink: $!"; 94 95 require FileHandle; 96 $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; 97 binmode $fh or die $!; 98 copy("file-$$",$fh); 99 $fh->close; 100 open(R, "<", "copy-$$") or die $!; $foo = <R>; close(R); 101 is $foo, "ok\n", 'copy(fn, fh): same contents'; 102 unlink "file-$$" or die "unlink: $!"; 103 104 ok !move("file-$$", "copy-$$"), "move on missing file"; 105 ok -e "copy-$$", ' target still there'; 106 107 # Doesn't really matter what time it is as long as its not now. 108 my $time = 1000000000.12345; 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 116 ok move("copy-$$", "file-$$"), 'move'; 117 ok -e "file-$$", ' destination exists'; 118 ok !-e "copy-$$", ' source does not'; 119 open(R, "<", "file-$$") or die $!; $foo = <R>; close(R); 120 is $foo, "ok\n", 'contents preserved'; 121 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 } 130 131 # trick: create lib/ if not exists - not needed in Perl core 132 unless (-d 'lib') { mkdir 'lib' or die $!; } 133 copy "file-$$", "lib"; 134 open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); 135 is $foo, "ok\n", 'copy(fn, dir): same contents'; 136 unlink "lib/file-$$" or die "unlink: $!"; 137 138 # Do it twice to ensure copying over the same file works. 139 copy "file-$$", "lib"; 140 open(R, "<", "lib/file-$$") or die $!; $foo = <R>; close(R); 141 is $foo, "ok\n", 'copy over the same file works'; 142 unlink "lib/file-$$" or die "unlink: $!"; 143 144 { 145 my $warnings = ''; 146 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 147 ok !copy("file-$$", "file-$$"), 'copy to itself fails'; 148 149 like $warnings, qr/are identical/, 'but warns'; 150 ok -s "file-$$", 'contents preserved'; 151 } 152 153 move "file-$$", "lib"; 154 open(R, "<", "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); 155 is $foo, "ok\n", 'move(fn, dir): same contents'; 156 ok !-e "file-$$", 'file moved indeed'; 157 unlink "lib/file-$$" or die "unlink: $!"; 158 159 SKIP: { 160 skip "Testing symlinks", 3 unless $Config{d_symlink}; 161 162 open(F, ">", "file-$$") or die $!; 163 print F "dummy content\n"; 164 close F; 165 if (!symlink("file-$$", "symlink-$$")) { 166 unlink "file-$$"; 167 skip "Can't create symlink", 3; 168 } 169 170 my $warnings = ''; 171 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 172 ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; 173 174 like $warnings, qr/are identical/, 'emits a warning'; 175 ok !-z "file-$$", 176 'rt.perl.org 5196: copying to itself would truncate the file'; 177 178 unlink "symlink-$$" or die $!; 179 unlink "file-$$" or die $!; 180 } 181 182 SKIP: { 183 skip "Testing hard links", 3 184 if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; 185 186 open(F, ">", "file-$$") or die $!; 187 print F "dummy content\n"; 188 close F; 189 link("file-$$", "hardlink-$$") or die $!; 190 191 my $warnings = ''; 192 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 193 ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; 194 195 like $warnings, qr/are identical/, 'emits a warning'; 196 ok ! -z "file-$$", 197 'rt.perl.org 5196: copying to itself would truncate the file'; 198 199 unlink "hardlink-$$" or die $!; 200 unlink "file-$$" or die $!; 201 } 202 203 open(F, ">", "file-$$") or die $!; 204 binmode F; 205 print F "this is file\n"; 206 close F; 207 208 my $copy_msg = "this is copy\n"; 209 open(F, ">", "copy-$$") or die $!; 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) 218 # is cached and we do not get a warning the second time round 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"; 227 open(F, "<", "copy-$$") or die $!; 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 $!; 234 235 # RT #73714 copy to file with leading whitespace failed 236 237 TODO: { 238 local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS'; 239 open(F, ">", "file-$$") or die $!; 240 close F; 241 copy "file-$$", " copy-$$"; 242 ok -e " copy-$$", "copy with leading whitespace"; 243 unlink "file-$$" or die "unlink: $!"; 244 unlink " copy-$$" or die "unlink: $!"; 245 } 246} 247 248my $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}; 256 257SKIP: { 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; 269 270 my $can_suid = $can_suidp->(); 271 skip "Can't suid on this $^O filesystem", $skips unless $can_suid; 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"; 276 skip "Copy maps POSIX permissions to VOS permissions.", $skips 277 if $^O eq "vos"; 278 skip "There be dragons here with DragonflyBSD.", $skips 279 if $^O eq 'dragonfly'; 280 281 282 # Just a sub to get better failure messages. 283 sub __ ($) { 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; 294 } 295 # Testing permission bits. 296 my $src = "file-$$"; 297 my $copy1 = "copy1-$$"; 298 my $copy2 = "copy2-$$"; 299 my $copy3 = "copy3-$$"; 300 my $copy4 = "copy4-$$"; 301 my $copy5 = "copy5-$$"; 302 my $copy6 = "copy6-$$"; 303 my $copyd = "copyd-$$"; 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 311 open $fh => ">", $copy6 or die $!; 312 close $fh or die $!; 313 314 my $old_mask = umask; 315 foreach my $test (@tests) { 316 foreach my $id (0 .. 7) { 317 my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; 318 # Make sure the copies do not exist. 319 ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; 320 321 $s_perm |= $id << 9; 322 $c_perm1 |= $id << 9; 323 diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) 324 unless ($ENV{PERL_CORE}); 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: 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: $!"; 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 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 $!; 356 binmode $fh; 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"); 376 is (__$perm3, __$c_perm3, "Permission bits not modified"); 377 is (__$perm6, __$c_perm3, "Permission bits not modified"); 378 } 379 } 380 umask $old_mask or die $!; 381 382 # Clean up. 383 ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, 384 $copy4, $copy5, $copy6; 385} 386 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; 423 is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right"; 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} 433 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 442my $NO_SUCH_FILE = "this_file_had_better_not_exist"; 443my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; 444 445use constant EXPECTED_SCALAR => 0; 446use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; 447 448my %subs = ( 449 copy => \&File::Copy::copy, 450 cp => \&File::Copy::cp, 451 move => \&File::Copy::move, 452 mv => \&File::Copy::mv, 453); 454 455SKIP: { 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 471SKIP: { 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)'; 477 binmode $IN; 478 binmode $OUT; 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 486use File::Temp qw(tempdir); 487use File::Spec; 488 489SKIP: { 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"); 506 like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i, 507 "error message should describe the problem"); 508 1 while unlink $temp_file; 509} 510 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 522done_testing(); 523 524END { 525 1 while unlink "copy-$$"; 526 1 while unlink "file-$$"; 527 1 while unlink "lib/file-$$"; 528} 529