lib/File/Copy.t

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