lib/File/Copy.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use Test::More;
   9
  10 my $TB = Test::More->builder;
  11
  12 plan tests => 48;
  13
  14 # We're going to override rename() later on but Perl has to see an override
  15 # at compile time to honor it.
  16 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }
  17
  18
  19 use File::Copy;
  20 use Config;
  21
  22 for my $cross_partition_test (0..1) {
  23   {
  24     # Simulate a cross-partition copy/move by forcing rename to
  25     # fail.
  26     no warnings 'redefine';
  27     *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
  28   }
  29
  30   # First we create a file
  31   open(F, ">file-$$") or die;
  32   binmode F; # for DOSISH platforms, because test 3 copies to stdout
  33   printf F "ok\n";
  34   close F;
  35
  36   copy "file-$$", "copy-$$";
  37
  38   open(F, "copy-$$") or die;
  39   $foo = <F>;
  40   close(F);
  41
  42   is -s "file-$$", -s "copy-$$";
  43
  44   is $foo, "ok\n";
  45
  46   binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
  47   # This outputs "ok" so its a test.
  48   copy "copy-$$", \*STDOUT;
  49   $TB->current_test($TB->current_test + 1);
  50   unlink "copy-$$" or die "unlink: $!";
  51
  52   open(F,"file-$$");
  53   copy(*F, "copy-$$");
  54   open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
  55   is $foo, "ok\n";
  56   unlink "copy-$$" or die "unlink: $!";
  57
  58   open(F,"file-$$");
  59   copy(\*F, "copy-$$");
  60   close(F) or die "close: $!";
  61   open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
  62   is $foo, "ok\n";
  63   unlink "copy-$$" or die "unlink: $!";
  64
  65   require IO::File;
  66   $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
  67   binmode $fh or die;
  68   copy("file-$$",$fh);
  69   $fh->close or die "close: $!";
  70   open(R, "copy-$$") or die; $foo = <R>; close(R);
  71   is $foo, "ok\n";
  72   unlink "copy-$$" or die "unlink: $!";
  73
  74   require FileHandle;
  75   my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
  76   binmode $fh or die;
  77   copy("file-$$",$fh);
  78   $fh->close;
  79   open(R, "copy-$$") or die; $foo = <R>; close(R);
  80   is $foo, "ok\n";
  81   unlink "file-$$" or die "unlink: $!";
  82
  83   ok !move("file-$$", "copy-$$"), "move on missing file";
  84   ok -e "copy-$$",                '  target still there';
  85
  86   # Doesn't really matter what time it is as long as its not now.
  87   my $time = 1000000000;
  88   utime( $time, $time, "copy-$$" );
  89
  90   # Recheck the mtime rather than rely on utime in case we're on a
  91   # system where utime doesn't work or there's no mtime at all.
  92   # The destination file will reflect the same difficulties.
  93   my $mtime = (stat("copy-$$"))[9];
  94
  95   ok move "copy-$$", "file-$$", 'move';
  96   ok -e "file-$$",              '  destination exists';
  97   ok !-e "copy-$$",              '  source does not';
  98   open(R, "file-$$") or die; $foo = <R>; close(R);
  99   is $foo, "ok\n";
 100
 101   my $dest_mtime = (stat("file-$$"))[9];
 102   is $dest_mtime, $mtime,
 103     "mtime preserved by copy()".
 104     ($cross_partition_test ? " while testing cross-partition" : "");
 105
 106   copy "file-$$", "lib";
 107   open(R, "lib/file-$$") or die; $foo = <R>; close(R);
 108   is $foo, "ok\n";
 109   unlink "lib/file-$$" or die "unlink: $!";
 110
 111   # Do it twice to ensure copying over the same file works.
 112   copy "file-$$", "lib";
 113   open(R, "lib/file-$$") or die; $foo = <R>; close(R);
 114   is $foo, "ok\n";
 115   unlink "lib/file-$$" or die "unlink: $!";
 116
 117   eval { copy("file-$$", "file-$$") };
 118   like $@, qr/are identical/;
 119   ok -s "file-$$";
 120
 121   move "file-$$", "lib";
 122   open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
 123   is $foo, "ok\n";
 124   ok !-e "file-$$";
 125   unlink "lib/file-$$" or die "unlink: $!";
 126
 127   SKIP: {
 128     skip "Testing symlinks", 2 unless $Config{d_symlink};
 129
 130     open(F, ">file-$$") or die $!;
 131     print F "dummy content\n";
 132     close F;
 133     symlink("file-$$", "symlink-$$") or die $!;
 134     eval { copy("file-$$", "symlink-$$") };
 135     like $@, qr/are identical/;
 136     ok !-z "file-$$",
 137       'rt.perl.org 5196: copying to itself would truncate the file';
 138
 139     unlink "symlink-$$";
 140     unlink "file-$$";
 141   }
 142
 143   SKIP: {
 144     skip "Testing hard links", 2 if !$Config{d_link} or $^O eq 'MSWin32';
 145
 146     open(F, ">file-$$") or die $!;
 147     print F "dummy content\n";
 148     close F;
 149     link("file-$$", "hardlink-$$") or die $!;
 150     eval { copy("file-$$", "hardlink-$$") };
 151     like $@, qr/are identical/;
 152     ok ! -z "file-$$",
 153       'rt.perl.org 5196: copying to itself would truncate the file';
 154
 155     unlink "hardlink-$$";
 156     unlink "file-$$";
 157   }
 158 }
 159
 160
 161 END {
 162     1 while unlink "file-$$";
 163     1 while unlink "lib/file-$$";
 164 }