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 28foreach 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 37for 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 240my $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 249SKIP: { 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 433my $NO_SUCH_FILE = "this_file_had_better_not_exist"; 434my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; 435 436use constant EXPECTED_SCALAR => 0; 437use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; 438 439my %subs = ( 440 copy => \&File::Copy::copy, 441 cp => \&File::Copy::cp, 442 move => \&File::Copy::move, 443 mv => \&File::Copy::mv, 444); 445 446SKIP: { 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 462SKIP: { 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 475use File::Temp qw(tempdir); 476use File::Spec; 477 478SKIP: { 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 512END { 513 1 while unlink "copy-$$"; 514 1 while unlink "file-$$"; 515 1 while unlink "lib/file-$$"; 516} 517