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 296 open my $fh => ">", $src or die $!; 297 close $fh or die $!; 298 299 open $fh => ">", $copy3 or die $!; 300 close $fh or die $!; 301 302 open $fh => ">", $copy6 or die $!; 303 close $fh or die $!; 304 305 my $old_mask = umask; 306 foreach my $test (@tests) { 307 foreach my $id (0 .. 7) { 308 my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; 309 # Make sure the copies do not exist. 310 ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; 311 312 $s_perm |= $id << 9; 313 $c_perm1 |= $id << 9; 314 diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) 315 unless ($ENV{PERL_CORE}); 316 317 # Test that we can actually set a file to the correct permission. 318 # Slightly convoluted, because some operating systems will let us 319 # set a directory, but not a file. These should all work: 320 mkdir $copy1 or die "Can't mkdir $copy1: $!"; 321 chmod $s_perm, $copy1 322 or die sprintf "Can't chmod %o $copy1: $!", $s_perm; 323 rmdir $copy1 324 or die sprintf "Can't rmdir $copy1: $!"; 325 open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; 326 close $fh0 or die "Can't close $copy1: $!"; 327 unless (chmod $s_perm, $copy1) { 328 $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) 329 for 1..6; 330 next; 331 } 332 my $perm0 = (stat $copy1) [2] & 07777; 333 unless ($perm0 == $s_perm) { 334 $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", 335 $s_perm, $perm0) 336 for 1..6; 337 next; 338 } 339 unlink $copy1 or die "Can't unlink $copy1: $!"; 340 341 (umask $umask) // die $!; 342 chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; 343 chmod $c_perm3 => $copy3 or die $!; 344 chmod $c_perm3 => $copy6 or die $!; 345 346 open my $fh => "<", $src or die $!; 347 348 copy ($src, $copy1); 349 copy ($fh, $copy2); 350 copy ($src, $copy3); 351 cp ($src, $copy4); 352 cp ($fh, $copy5); 353 cp ($src, $copy6); 354 355 my $permdef = 0666 & ~$umask; 356 my $perm1 = (stat $copy1) [2] & 07777; 357 my $perm2 = (stat $copy2) [2] & 07777; 358 my $perm3 = (stat $copy3) [2] & 07777; 359 my $perm4 = (stat $copy4) [2] & 07777; 360 my $perm5 = (stat $copy5) [2] & 07777; 361 my $perm6 = (stat $copy6) [2] & 07777; 362 is (__$perm1, __$permdef, "Permission bits set correctly"); 363 is (__$perm2, __$permdef, "Permission bits set correctly"); 364 is (__$perm4, __$c_perm1, "Permission bits set correctly"); 365 is (__$perm5, __$c_perm1, "Permission bits set correctly"); 366 TODO: { 367 local $TODO = 'Permission bits inconsistent under cygwin' 368 if $^O eq 'cygwin'; 369 is (__$perm3, __$c_perm3, "Permission bits not modified"); 370 is (__$perm6, __$c_perm3, "Permission bits not modified"); 371 } 372 } 373 } 374 umask $old_mask or die $!; 375 376 # Clean up. 377 ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, 378 $copy4, $copy5, $copy6; 379} 380 381{ 382 package Crash; 383 # a package overloaded suspiciously like IO::Scalar 384 use overload '""' => sub { ${$_[0]} }; 385 use overload 'bool' => sub { 1 }; 386 sub new { 387 my ($class, $name) = @_; 388 bless \$name, $class; 389 } 390 391 package Zowie; 392 # a different package overloaded suspiciously like IO::Scalar 393 use overload '""' => sub { ${$_[0]} }; 394 use overload 'bool' => sub { 1 }; 395 sub new { 396 my ($class, $name) = @_; 397 bless \$name, $class; 398 } 399} 400{ 401 my $object = Crash->new('whack_eth'); 402 my %what = (plain => "$object", 403 object1 => $object, 404 object2 => Zowie->new('whack_eth'), 405 object2 => Zowie->new('whack_eth'), 406 ); 407 408 my @warnings; 409 local $SIG{__WARN__} = sub { 410 push @warnings, @_; 411 }; 412 413 foreach my $left (qw(plain object1 object2)) { 414 foreach my $right (qw(plain object1 object2)) { 415 @warnings = (); 416 $! = 0; 417 is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right"; 418 is $@, '', 'No croaking'; 419 is $!, '', 'No system call errors'; 420 is @warnings, 1, 'Exactly 1 warning'; 421 like $warnings[0], 422 qr/'$object' and '$object' are identical \(not copied\)/, 423 'with the text we expect'; 424 } 425 } 426} 427 428# On Unix systems, File::Copy always returns 0 to signal failure, 429# even when in list context! On Windows, it always returns "" to signal 430# failure. 431# 432# While returning a list containing a false value is arguably a bad 433# API design, at the very least we can make sure it always returns 434# the same false value. 435 436my $NO_SUCH_FILE = "this_file_had_better_not_exist"; 437my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; 438 439use constant EXPECTED_SCALAR => 0; 440use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; 441 442my %subs = ( 443 copy => \&File::Copy::copy, 444 cp => \&File::Copy::cp, 445 move => \&File::Copy::move, 446 mv => \&File::Copy::mv, 447); 448 449SKIP: { 450 skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) 451 if (-e $NO_SUCH_FILE); 452 453 foreach my $name (keys %subs) { 454 455 my $sub = $subs{$name}; 456 457 my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 458 is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); 459 460 my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 461 is_deeply( \@array, EXPECTED_LIST, "$name in list context"); 462 } 463} 464 465SKIP: { 466 skip("fork required to test pipe copying", 2) 467 if (!$Config{'d_fork'}); 468 469 open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; 470 open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; 471 472 ok(copy($IN, $OUT), "copy pipe to another"); 473 close($OUT); 474 is($? >> 8, 55, "content copied through the pipes"); 475 close($IN); 476} 477 478use File::Temp qw(tempdir); 479use File::Spec; 480 481SKIP: { 482 # RT #111126: File::Copy copy() zeros file when copying a file 483 # into the same directory it is stored in 484 485 my $temp_dir = tempdir( CLEANUP => 1 ); 486 my $temp_file = File::Spec->catfile($temp_dir, "somefile"); 487 488 open my $fh, ">", $temp_file 489 or skip "Cannot create $temp_file: $!", 2; 490 print $fh "Just some data"; 491 close $fh 492 or skip "Cannot close $temp_file: $!", 2; 493 494 my $warn_message = ""; 495 local $SIG{__WARN__} = sub { $warn_message .= "@_" }; 496 ok(!copy($temp_file, $temp_dir), 497 "Copy of foo/file to foo/ should fail"); 498 like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i, 499 "error message should describe the problem"); 500 1 while unlink $temp_file; 501} 502 503{ 504 open(my $F, '>', "file-$$") or die $!; 505 binmode $F; # for DOSISH platforms 506 printf $F "ok\n"; 507 close $F; 508 509 my $buffer = (1024 * 1024 * 2) + 1; 510 is eval {copy "file-$$", "copy-$$", $buffer}, 1, 511 "copy with buffer above normal size"; 512} 513 514 515END { 516 1 while unlink "copy-$$"; 517 1 while unlink "file-$$"; 518 1 while unlink "lib/file-$$"; 519} 520