lib/File/Copy.t

   1 #!./perl -w
   2
   3 BEGIN {
   4    if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8 }
   9
  10 use strict;
  11 use warnings;
  12
  13 use Test::More;
  14
  15 my $TB = Test::More->builder;
  16
  17 plan 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.
  21 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
  22
  23
  24 use File::Copy qw(copy move cp);
  25 use Config;
  26
  27 # If we have Time::HiRes, File::Copy loaded it for us.
  28 BEGIN {
  29   eval { Time::HiRes->import(qw( stat utime )) };
  30   note "Testing Time::HiRes::utime support" unless $@;
  31 }
  32
  33 foreach 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
  42 for 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
 247 my $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
 256 SKIP: {
 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
 441 my $NO_SUCH_FILE       = "this_file_had_better_not_exist";
 442 my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports";
 443
 444 use constant EXPECTED_SCALAR => 0;
 445 use constant EXPECTED_LIST   => [ EXPECTED_SCALAR ];
 446
 447 my %subs = (
 448     copy    =>  \&File::Copy::copy,
 449     cp      =>  \&File::Copy::cp,
 450     move    =>  \&File::Copy::move,
 451     mv      =>  \&File::Copy::mv,
 452 );
 453
 454 SKIP: {
 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
 470 SKIP: {
 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
 485 use File::Temp qw(tempdir);
 486 use File::Spec;
 487
 488 SKIP: {
 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
 522 END {
 523     1 while unlink "copy-$$";
 524     1 while unlink "file-$$";
 525     1 while unlink "lib/file-$$";
 526 }