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 => 463; 18 19# We're 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(fn, fn) succeeds'; 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 don't 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 269 # Just a sub to get better failure messages. 270 sub __ ($) { 271 my $perm = shift; 272 my $id = 07000 & $perm; 273 $id >>= 9; 274 $perm &= 0777; 275 my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]} 276 split // => sprintf "%03o" => $perm; 277 if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} 278 if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;} 279 if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;} 280 join "" => @chunks; 281 } 282 # Testing permission bits. 283 my $src = "file-$$"; 284 my $copy1 = "copy1-$$"; 285 my $copy2 = "copy2-$$"; 286 my $copy3 = "copy3-$$"; 287 my $copy4 = "copy4-$$"; 288 my $copy5 = "copy5-$$"; 289 my $copy6 = "copy6-$$"; 290 291 open my $fh => ">", $src or die $!; 292 close $fh or die $!; 293 294 open $fh => ">", $copy3 or die $!; 295 close $fh or die $!; 296 297 open $fh => ">", $copy6 or die $!; 298 close $fh or die $!; 299 300 my $old_mask = umask; 301 foreach my $test (@tests) { 302 foreach my $id (0 .. 7) { 303 my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test; 304 # Make sure the copies doesn't exist. 305 ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5; 306 307 $s_perm |= $id << 9; 308 $c_perm1 |= $id << 9; 309 diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask) 310 unless ($ENV{PERL_CORE}); 311 312 # Test that we can actually set a file to the correct permission. 313 # Slightly convoluted, because some operating systems will let us 314 # set a directory, but not a file. These should all work: 315 mkdir $copy1 or die "Can't mkdir $copy1: $!"; 316 chmod $s_perm, $copy1 317 or die sprintf "Can't chmod %o $copy1: $!", $s_perm; 318 rmdir $copy1 319 or die sprintf "Can't rmdir $copy1: $!"; 320 open my $fh0, '>', $copy1 or die "Can't open $copy1: $!"; 321 close $fh0 or die "Can't close $copy1: $!"; 322 unless (chmod $s_perm, $copy1) { 323 $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm) 324 for 1..6; 325 next; 326 } 327 my $perm0 = (stat $copy1) [2] & 07777; 328 unless ($perm0 == $s_perm) { 329 $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o", 330 $s_perm, $perm0) 331 for 1..6; 332 next; 333 } 334 unlink $copy1 or die "Can't unlink $copy1: $!"; 335 336 (umask $umask) // die $!; 337 chmod $s_perm => $src or die sprintf "$!: $src => %o", $s_perm; 338 chmod $c_perm3 => $copy3 or die $!; 339 chmod $c_perm3 => $copy6 or die $!; 340 341 open my $fh => "<", $src or die $!; 342 343 copy ($src, $copy1); 344 copy ($fh, $copy2); 345 copy ($src, $copy3); 346 cp ($src, $copy4); 347 cp ($fh, $copy5); 348 cp ($src, $copy6); 349 350 my $permdef = 0666 & ~$umask; 351 my $perm1 = (stat $copy1) [2] & 07777; 352 my $perm2 = (stat $copy2) [2] & 07777; 353 my $perm3 = (stat $copy3) [2] & 07777; 354 my $perm4 = (stat $copy4) [2] & 07777; 355 my $perm5 = (stat $copy5) [2] & 07777; 356 my $perm6 = (stat $copy6) [2] & 07777; 357 is (__$perm1, __$permdef, "Permission bits set correctly"); 358 is (__$perm2, __$permdef, "Permission bits set correctly"); 359 is (__$perm4, __$c_perm1, "Permission bits set correctly"); 360 is (__$perm5, __$c_perm1, "Permission bits set correctly"); 361 TODO: { 362 local $TODO = 'Permission bits inconsistent under cygwin' 363 if $^O eq 'cygwin'; 364 is (__$perm3, __$c_perm3, "Permission bits not modified"); 365 is (__$perm6, __$c_perm3, "Permission bits not modified"); 366 } 367 } 368 } 369 umask $old_mask or die $!; 370 371 # Clean up. 372 ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3, 373 $copy4, $copy5, $copy6; 374} 375 376{ 377 package Crash; 378 # a package overloaded suspiciously like IO::Scalar 379 use overload '""' => sub { ${$_[0]} }; 380 use overload 'bool' => sub { 1 }; 381 sub new { 382 my ($class, $name) = @_; 383 bless \$name, $class; 384 } 385 386 package Zowie; 387 # a different package overloaded suspiciously like IO::Scalar 388 use overload '""' => sub { ${$_[0]} }; 389 use overload 'bool' => sub { 1 }; 390 sub new { 391 my ($class, $name) = @_; 392 bless \$name, $class; 393 } 394} 395{ 396 my $object = Crash->new('whack_eth'); 397 my %what = (plain => "$object", 398 object1 => $object, 399 object2 => Zowie->new('whack_eth'), 400 object2 => Zowie->new('whack_eth'), 401 ); 402 403 my @warnings; 404 local $SIG{__WARN__} = sub { 405 push @warnings, @_; 406 }; 407 408 foreach my $left (qw(plain object1 object2)) { 409 foreach my $right (qw(plain object1 object2)) { 410 @warnings = (); 411 $! = 0; 412 is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right"; 413 is $@, '', 'No croaking'; 414 is $!, '', 'No system call errors'; 415 is @warnings, 1, 'Exactly 1 warning'; 416 like $warnings[0], 417 qr/'$object' and '$object' are identical \(not copied\)/, 418 'with the text we expect'; 419 } 420 } 421} 422 423# On Unix systems, File::Copy always returns 0 to signal failure, 424# even when in list context! On Windows, it always returns "" to signal 425# failure. 426# 427# While returning a list containing a false value is arguably a bad 428# API design, at the very least we can make sure it always returns 429# the same false value. 430 431my $NO_SUCH_FILE = "this_file_had_better_not_exist"; 432my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports"; 433 434use constant EXPECTED_SCALAR => 0; 435use constant EXPECTED_LIST => [ EXPECTED_SCALAR ]; 436 437my %subs = ( 438 copy => \&File::Copy::copy, 439 cp => \&File::Copy::cp, 440 move => \&File::Copy::move, 441 mv => \&File::Copy::mv, 442); 443 444SKIP: { 445 skip( "Test can't run with $NO_SUCH_FILE existing", 2 * keys %subs) 446 if (-e $NO_SUCH_FILE); 447 448 foreach my $name (keys %subs) { 449 450 my $sub = $subs{$name}; 451 452 my $scalar = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 453 is( $scalar, EXPECTED_SCALAR, "$name in scalar context"); 454 455 my @array = $sub->( $NO_SUCH_FILE, $NO_SUCH_OTHER_FILE ); 456 is_deeply( \@array, EXPECTED_LIST, "$name in list context"); 457 } 458} 459 460SKIP: { 461 skip("fork required to test pipe copying", 2) 462 if (!$Config{'d_fork'}); 463 464 open(my $IN, "-|") || exec $^X, '-e', 'print "Hello, world!\n"'; 465 open(my $OUT, "|-") || exec $^X, '-ne', 'exit(/Hello/ ? 55 : 0)'; 466 467 ok(copy($IN, $OUT), "copy pipe to another"); 468 close($OUT); 469 is($? >> 8, 55, "content copied through the pipes"); 470 close($IN); 471} 472 473END { 474 1 while unlink "file-$$"; 475 1 while unlink "lib/file-$$"; 476} 477