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