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 copy(*F, "copy-$$"); 75 open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); 76 is $foo, "ok\n", 'copy(*F, fn): same contents'; 77 unlink "copy-$$" or die "unlink: $!"; 78 79 open(F,"file-$$"); 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 symlink("file-$$", "symlink-$$") or die $!; 166 167 my $warnings = ''; 168 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 169 ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; 170 171 like $warnings, qr/are identical/, 'emits a warning'; 172 ok !-z "file-$$", 173 'rt.perl.org 5196: copying to itself would truncate the file'; 174 175 unlink "symlink-$$" or die $!; 176 unlink "file-$$" or die $!; 177 } 178 179 SKIP: { 180 skip "Testing hard links", 3 181 if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; 182 183 open(F, ">file-$$") or die $!; 184 print F "dummy content\n"; 185 close F; 186 link("file-$$", "hardlink-$$") or die $!; 187 188 my $warnings = ''; 189 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 190 ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; 191 192 like $warnings, qr/are identical/, 'emits a warning'; 193 ok ! -z "file-$$", 194 'rt.perl.org 5196: copying to itself would truncate the file'; 195 196 unlink "hardlink-$$" or die $!; 197 unlink "file-$$" or die $!; 198 } 199 200 open(F, ">file-$$") or die $!; 201 binmode F; 202 print F "this is file\n"; 203 close F; 204 205 my $copy_msg = "this is copy\n"; 206 open(F, ">copy-$$") or die $!; 207 binmode F; 208 print F $copy_msg; 209 close F; 210 211 my @warnings; 212 local $SIG{__WARN__} = sub { push @warnings, join '', @_ }; 213 214 # pie-$$ so that we force a non-constant, else the numeric conversion (of 0) 215 # is cached and we do not get a warning the second time round 216 is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef, 217 "a bad buffer size fails to copy"; 218 like $@, qr/Bad buffer size for copy/, "with a helpful error message"; 219 unless (is scalar @warnings, 1, "There is 1 warning") { 220 diag $_ foreach @warnings; 221 } 222 223 is -s "copy-$$", length $copy_msg, "but does not truncate the destination"; 224 open(F, "copy-$$") or die $!; 225 $foo = <F>; 226 close(F); 227 is $foo, $copy_msg, "nor change the destination's contents"; 228 229 unlink "file-$$" or die $!; 230 unlink "copy-$$" or die $!; 231 232 # RT #73714 copy to file with leading whitespace failed 233 234 TODO: { 235 local $TODO = 'spaces in filenames require DECC$EFS_CHARSET enabled' if $^O eq 'VMS'; 236 open(F, ">file-$$") or die $!; 237 close F; 238 copy "file-$$", " copy-$$"; 239 ok -e " copy-$$", "copy with leading whitespace"; 240 unlink "file-$$" or die "unlink: $!"; 241 unlink " copy-$$" or die "unlink: $!"; 242 } 243} 244 245my $can_suidp = sub { 246 my $dir = "suid-$$"; 247 my $ok = 1; 248 mkdir $dir or die "Can't mkdir($dir) for suid test"; 249 $ok = 0 unless chmod 2000, $dir; 250 rmdir $dir; 251 return $ok; 252}; 253 254SKIP: { 255 my @tests = ( 256 [0000, 0777, 0777, 0777], 257 [0000, 0751, 0751, 0644], 258 [0022, 0777, 0755, 0206], 259 [0022, 0415, 0415, 0666], 260 [0077, 0777, 0700, 0333], 261 [0027, 0755, 0750, 0251], 262 [0777, 0751, 0000, 0215], 263 ); 264 265 my $skips = @tests * 6 * 8; 266 267 my $can_suid = $can_suidp->(); 268 skip "Can't suid on this $^O filesystem", $skips unless $can_suid; 269 skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips 270 if $^O eq 'VMS'; 271 skip "Copy doesn't set file permissions correctly on Win32.", $skips 272 if $^O eq "MSWin32"; 273 skip "Copy maps POSIX permissions to VOS permissions.", $skips 274 if $^O eq "vos"; 275 skip "There be dragons here with DragonflyBSD.", $skips 276 if $^O eq 'dragonfly'; 277 278 279 # Just a sub to get better failure messages. 280 sub __ ($) { 281 my $perm = shift; 282 my $id = 07000 & $perm; 283 $id >>= 9; 284 $perm &= 0777; 285 my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} 286 split // => sprintf "%03o" => $perm; 287 if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} 288 if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} 289 if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} 290 join "" => @chunks; 291 } 292 # Testing permission bits. 293 my $src = "file-$$"; 294 my $copy1 = "copy1-$$"; 295 my $copy2 = "copy2-$$"; 296 my $copy3 = "copy3-$$"; 297 my $copy4 = "copy4-$$"; 298 my $copy5 = "copy5-$$"; 299 my $copy6 = "copy6-$$"; 300 my $copyd = "copyd-$$"; 301 302 open my $fh => ">", $src or die $!; 303 close $fh or die $!; 304 305 open $fh => ">", $copy3 or die $!; 306 close $fh or die $!; 307 308 open $fh => ">", $copy6 or die $!; 309 close $fh or die $!; 310 311 my $old_mask = umask; 312 foreach my $test (@tests) { 313 foreach my $id (0 .. 7) { 314 my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; 315 # Make sure the copies do not exist. 316 ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; 317 318 $s_perm |= $id << 9; 319 $c_perm1 |= $id << 9; 320 diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) 321 unless ($ENV{PERL_CORE}); 322 323 # Test that we can actually set a file to the correct permission. 324 # Slightly convoluted, because some operating systems will let us 325 # set a directory, but not a file. These should all work: 326 mkdir $copyd or die "Can't mkdir $copyd: $!"; 327 chmod $s_perm, $copyd 328 or die sprintf "Can't chmod %o $copyd: $!", $s_perm; 329 rmdir $copyd 330 or die sprintf "Can't rmdir $copyd: $!"; 331 open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; 332 close $fh0 or die "Can't close $copy1: $!"; 333 unless (chmod $s_perm, $copy1) { 334 $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) 335 for 1..6; 336 next; 337 } 338 my $perm0 = (stat $copy1) [2] & 07777; 339 unless ($perm0 == $s_perm) { 340 $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", 341 $s_perm, $perm0) 342 for 1..6; 343 next; 344 } 345 unlink $copy1 or die "Can't unlink $copy1: $!"; 346 347 (umask $umask) // die $!; 348 chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; 349 chmod $c_perm3 => $copy3 or die $!; 350 chmod $c_perm3 => $copy6 or die $!; 351 352 open my $fh => "<", $src or die $!; 353 354 copy ($src, $copy1); 355 copy ($fh, $copy2); 356 copy ($src, $copy3); 357 cp ($src, $copy4); 358 cp ($fh, $copy5); 359 cp ($src, $copy6); 360 361 my $permdef = 0666 & ~$umask; 362 my $perm1 = (stat $copy1) [2] & 07777; 363 my $perm2 = (stat $copy2) [2] & 07777; 364 my $perm3 = (stat $copy3) [2] & 07777; 365 my $perm4 = (stat $copy4) [2] & 07777; 366 my $perm5 = (stat $copy5) [2] & 07777; 367 my $perm6 = (stat $copy6) [2] & 07777; 368 is (__$perm1, __$permdef, "Permission bits set correctly"); 369 is (__$perm2, __$permdef, "Permission bits set correctly"); 370 is (__$perm4, __$c_perm1, "Permission bits set correctly"); 371 is (__$perm5, __$c_perm1, "Permission bits set correctly"); 372 is (__$perm3, __$c_perm3, "Permission bits not modified"); 373 is (__$perm6, __$c_perm3, "Permission bits not modified"); 374 } 375 } 376 umask $old_mask or die $!; 377 378 # Clean up. 379 ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, 380 $copy4, $copy5, $copy6; 381} 382 383{ 384 package Crash; 385 # a package overloaded suspiciously like IO::Scalar 386 use overload '""' => sub { ${$_[0]} }; 387 use overload 'bool' => sub { 1 }; 388 sub new { 389 my ($class, $name) = @_; 390 bless \$name, $class; 391 } 392 393 package Zowie; 394 # a different package overloaded suspiciously like IO::Scalar 395 use overload '""' => sub { ${$_[0]} }; 396 use overload 'bool' => sub { 1 }; 397 sub new { 398 my ($class, $name) = @_; 399 bless \$name, $class; 400 } 401} 402{ 403 my $object = Crash->new('whack_eth'); 404 my %what = (plain => "$object", 405 object1 => $object, 406 object2 => Zowie->new('whack_eth'), 407 object2 => Zowie->new('whack_eth'), 408 ); 409 410 my @warnings; 411 local $SIG{__WARN__} = sub { 412 push @warnings, @_; 413 }; 414 415 foreach my $left (qw(plain object1 object2)) { 416 foreach my $right (qw(plain object1 object2)) { 417 @warnings = (); 418 $! = 0; 419 is eval {copy $what{$left}, $what{$right}}, 0, "copy $left $right"; 420 is $@, '', 'No croaking'; 421 is $!, '', 'No system call errors'; 422 is @warnings, 1, 'Exactly 1 warning'; 423 like $warnings[0], 424 qr/'$object' and '$object' are identical \(not copied\)/, 425 'with the text we expect'; 426 } 427 } 428} 429 430# On Unix systems, File::Copy always returns 0 to signal failure, 431# even when in list context! On Windows, it always returns "" to signal 432# failure. 433# 434# While returning a list containing a false value is arguably a bad 435# API design, at the very least we can make sure it always returns 436# the same false value. 437 438my $NO_SUCH_FILE = "this_file_had_better_not_exist"; 439my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; 440 441use constant EXPECTED_SCALAR => 0; 442use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; 443 444my %subs = ( 445 copy => \&File::Copy::copy, 446 cp => \&File::Copy::cp, 447 move => \&File::Copy::move, 448 mv => \&File::Copy::mv, 449); 450 451SKIP: { 452 skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) 453 if (-e $NO_SUCH_FILE); 454 455 foreach my $name (keys %subs) { 456 457 my $sub = $subs{$name}; 458 459 my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 460 is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); 461 462 my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 463 is_deeply( \@array, EXPECTED_LIST, "$name in list context"); 464 } 465} 466 467SKIP: { 468 skip("fork required to test pipe copying", 2) 469 if (!$Config{'d_fork'}); 470 471 open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; 472 open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; 473 474 ok(copy($IN, $OUT), "copy pipe to another"); 475 close($OUT); 476 is($? >> 8, 55, "content copied through the pipes"); 477 close($IN); 478} 479 480use File::Temp qw(tempdir); 481use File::Spec; 482 483SKIP: { 484 # RT #111126: File::Copy copy() zeros file when copying a file 485 # into the same directory it is stored in 486 487 my $temp_dir = tempdir( CLEANUP => 1 ); 488 my $temp_file = File::Spec->catfile($temp_dir, "somefile"); 489 490 open my $fh, ">", $temp_file 491 or skip "Cannot create $temp_file: $!", 2; 492 print $fh "Just some data"; 493 close $fh 494 or skip "Cannot close $temp_file: $!", 2; 495 496 my $warn_message = ""; 497 local $SIG{__WARN__} = sub { $warn_message .= "@_" }; 498 ok(!copy($temp_file, $temp_dir), 499 "Copy of foo/file to foo/ should fail"); 500 like($warn_message, qr/^\Q'$temp_file' and '$temp_file'\E are identical.*Copy\.t/i, 501 "error message should describe the problem"); 502 1 while unlink $temp_file; 503} 504 505{ 506 open(my $F, '>', "file-$$") or die $!; 507 binmode $F; # for DOSISH platforms 508 printf $F "ok\n"; 509 close $F; 510 511 my $buffer = (1024 * 1024 * 2) + 1; 512 is eval {copy "file-$$", "copy-$$", $buffer}, 1, 513 "copy with buffer above normal size"; 514} 515 516 517END { 518 1 while unlink "copy-$$"; 519 1 while unlink "file-$$"; 520 1 while unlink "lib/file-$$"; 521} 522