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