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 => 465;
  18
  19 # We're 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
  28 foreach 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
  37 for 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 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
 240 my $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
 249 SKIP: {
 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
 271     # Just a sub to get better failure messages.
 272     sub __ ($) {
 273         my $perm   = shift;
 274         my $id     = 07000 & $perm;
 275            $id   >>= 9;
 276         $perm     &= 0777;
 277         my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]}
 278                      split // => sprintf "%03o" => $perm;
 279         if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
 280         if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
 281         if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;}
 282         join "" => @chunks;
 283     }
 284     # Testing permission bits.
 285     my $src   = "file-$$";
 286     my $copy1 = "copy1-$$";
 287     my $copy2 = "copy2-$$";
 288     my $copy3 = "copy3-$$";
 289     my $copy4 = "copy4-$$";
 290     my $copy5 = "copy5-$$";
 291     my $copy6 = "copy6-$$";
 292
 293     open my $fh => ">", $src   or die $!;
 294     close   $fh                or die $!;
 295
 296     open    $fh => ">", $copy3 or die $!;
 297     close   $fh                or die $!;
 298
 299     open    $fh => ">", $copy6 or die $!;
 300     close   $fh                or die $!;
 301
 302     my $old_mask = umask;
 303     foreach my $test (@tests) {
 304         foreach my $id (0 .. 7) {
 305             my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
 306             # Make sure the copies doesn't exist.
 307             ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;
 308
 309             $s_perm  |= $id << 9;
 310             $c_perm1 |= $id << 9;
 311             diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask)
 312                 unless ($ENV{PERL_CORE});
 313
 314             # Test that we can actually set a file to the correct permission.
 315             # Slightly convoluted, because some operating systems will let us
 316             # set a directory, but not a file. These should all work:
 317             mkdir $copy1 or die "Can't mkdir $copy1: $!";
 318             chmod $s_perm, $copy1
 319                 or die sprintf "Can't chmod %o $copy1: $!", $s_perm;
 320             rmdir $copy1
 321                 or die sprintf "Can't rmdir $copy1: $!";
 322             open my $fh0, '>', $copy1 or die "Can't open $copy1: $!";
 323             close $fh0 or die "Can't close $copy1: $!";
 324             unless (chmod $s_perm, $copy1) {
 325                 $TB->skip(sprintf "Can't chmod $copy1 to %o: $!", $s_perm)
 326                     for 1..6;
 327                 next;
 328             }
 329             my $perm0 = (stat $copy1) [2] & 07777;
 330             unless ($perm0 == $s_perm) {
 331                 $TB->skip(sprintf "chmod %o $copy1 lies - we actually get %o",
 332                           $s_perm, $perm0)
 333                     for 1..6;
 334                 next;
 335             }
 336             unlink $copy1 or die "Can't unlink $copy1: $!";
 337
 338             (umask $umask) // die $!;
 339             chmod $s_perm  => $src   or die sprintf "$!: $src => %o", $s_perm;
 340             chmod $c_perm3 => $copy3 or die $!;
 341             chmod $c_perm3 => $copy6 or die $!;
 342
 343             open my $fh => "<", $src or die $!;
 344
 345             copy ($src, $copy1);
 346             copy ($fh,  $copy2);
 347             copy ($src, $copy3);
 348             cp   ($src, $copy4);
 349             cp   ($fh,  $copy5);
 350             cp   ($src, $copy6);
 351
 352             my $permdef = 0666 & ~$umask;
 353             my $perm1 = (stat $copy1) [2] & 07777;
 354             my $perm2 = (stat $copy2) [2] & 07777;
 355             my $perm3 = (stat $copy3) [2] & 07777;
 356             my $perm4 = (stat $copy4) [2] & 07777;
 357             my $perm5 = (stat $copy5) [2] & 07777;
 358             my $perm6 = (stat $copy6) [2] & 07777;
 359             is (__$perm1, __$permdef, "Permission bits set correctly");
 360             is (__$perm2, __$permdef, "Permission bits set correctly");
 361             is (__$perm4, __$c_perm1, "Permission bits set correctly");
 362             is (__$perm5, __$c_perm1, "Permission bits set correctly");
 363             TODO: {
 364                 local $TODO = 'Permission bits inconsistent under cygwin'
 365                    if $^O eq 'cygwin';
 366                 is (__$perm3, __$c_perm3, "Permission bits not modified");
 367                 is (__$perm6, __$c_perm3, "Permission bits not modified");
 368             }
 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
 433 my $NO_SUCH_FILE       = "this_file_had_better_not_exist";
 434 my $NO_SUCH_OTHER_FILE = "my_goodness_im_sick_of_airports";
 435
 436 use constant EXPECTED_SCALAR => 0;
 437 use constant EXPECTED_LIST   => [ EXPECTED_SCALAR ];
 438
 439 my %subs = (
 440     copy    =>  \&File::Copy::copy,
 441     cp      =>  \&File::Copy::cp,
 442     move    =>  \&File::Copy::move,
 443     mv      =>  \&File::Copy::mv,
 444 );
 445
 446 SKIP: {
 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
 462 SKIP: {
 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
 475 use File::Temp qw(tempdir);
 476 use File::Spec;
 477
 478 SKIP: {
 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 END {
 501     1 while unlink "file-$$";
 502     1 while unlink "lib/file-$$";
 503 }