This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence verbosity in lib/File/Copy.t during 'make test' in core
[perl5.git] / 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 => 451;
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(fn, fn) succeeds';
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
228
229 SKIP: {
230     my @tests = (
231         [0000,  0777,  0777,  0777],
232         [0000,  0751,  0751,  0644],
233         [0022,  0777,  0755,  0206],
234         [0022,  0415,  0415,  0666],
235         [0077,  0777,  0700,  0333],
236         [0027,  0755,  0750,  0251],
237         [0777,  0751,  0000,  0215],
238     );
239
240     my $skips = @tests * 6 * 8;
241
242     skip "-- Copy preserves RMS defaults, not POSIX permissions.", $skips
243           if $^O eq 'VMS';
244     skip "Copy doesn't set file permissions correctly on Win32.",  $skips
245           if $^O eq "MSWin32";
246
247     # Just a sub to get better failure messages.
248     sub __ ($) {
249         my $perm   = shift;
250         my $id     = 07000 & $perm;
251            $id   >>= 9;
252         $perm     &= 0777;
253         my @chunks = map {(qw [--- --x -w- -wx r-- r-x rw- rwx]) [$_]}
254                      split // => sprintf "%03o" => $perm;
255         if ($id & 4) {$chunks [0] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
256         if ($id & 2) {$chunks [1] =~ s/(.)$/$1 eq '-' ? 'S' : 's'/e;}
257         if ($id & 1) {$chunks [2] =~ s/(.)$/$1 eq '-' ? 'T' : 't'/e;}
258         join "" => @chunks;
259     }
260     # Testing permission bits.
261     my $src   = "file-$$";
262     my $copy1 = "copy1-$$";
263     my $copy2 = "copy2-$$";
264     my $copy3 = "copy3-$$";
265     my $copy4 = "copy4-$$";
266     my $copy5 = "copy5-$$";
267     my $copy6 = "copy6-$$";
268
269     open my $fh => ">", $src   or die $!;
270     close   $fh                or die $!;
271
272     open    $fh => ">", $copy3 or die $!;
273     close   $fh                or die $!;
274
275     open    $fh => ">", $copy6 or die $!;
276     close   $fh                or die $!;
277
278     my $old_mask = umask;
279     foreach my $test (@tests) {
280         foreach my $id (0 .. 7) {
281             my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
282             # Make sure the copies doesn't exist.
283             ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;
284
285             $s_perm  |= $id << 9;
286             $c_perm1 |= $id << 9;
287             diag(sprintf "Src permission: %04o; umask %03o\n", $s_perm, $umask)
288                 unless ($ENV{PERL_CORE});
289             (umask $umask) // die $!;
290             chmod $s_perm  => $src   or die sprintf "$!: $src => %o", $s_perm;
291             chmod $c_perm3 => $copy3 or die $!;
292             chmod $c_perm3 => $copy6 or die $!;
293
294             open my $fh => "<", $src or die $!;
295
296             copy ($src, $copy1);
297             copy ($fh,  $copy2);
298             copy ($src, $copy3);
299             cp   ($src, $copy4);
300             cp   ($fh,  $copy5);
301             cp   ($src, $copy6);
302
303             my $permdef = 0666 & ~$umask;
304             my $perm1 = (stat $copy1) [2] & 07777;
305             my $perm2 = (stat $copy2) [2] & 07777;
306             my $perm3 = (stat $copy3) [2] & 07777;
307             my $perm4 = (stat $copy4) [2] & 07777;
308             my $perm5 = (stat $copy5) [2] & 07777;
309             my $perm6 = (stat $copy6) [2] & 07777;
310             is (__$perm1, __$permdef, "Permission bits set correctly");
311             is (__$perm2, __$permdef, "Permission bits set correctly");
312             is (__$perm4, __$c_perm1, "Permission bits set correctly");
313             is (__$perm5, __$c_perm1, "Permission bits set correctly");
314             TODO: {
315                 local $TODO = 'Permission bits inconsistent under cygwin'
316                    if $^O eq 'cygwin';
317                 is (__$perm3, __$c_perm3, "Permission bits not modified");
318                 is (__$perm6, __$c_perm3, "Permission bits not modified");
319             }
320         }
321     }
322     umask $old_mask or die $!;
323
324     # Clean up.
325     ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3,
326                                              $copy4, $copy5, $copy6;
327 }
328
329 {
330     package Crash;
331     # a package overloaded suspiciously like IO::Scalar
332     use overload '""' => sub { ${$_[0]} };
333     use overload 'bool' => sub { 1 };
334     sub new {
335         my ($class, $name) = @_;
336         bless \$name, $class;
337     }
338
339     package Zowie;
340     # a different package overloaded suspiciously like IO::Scalar
341     use overload '""' => sub { ${$_[0]} };
342     use overload 'bool' => sub { 1 };
343     sub new {
344         my ($class, $name) = @_;
345         bless \$name, $class;
346     }
347 }
348 {
349     my $object = Crash->new('whack_eth');
350     my %what = (plain => "$object",
351                 object1 => $object,
352                 object2 => Zowie->new('whack_eth'),
353                 object2 => Zowie->new('whack_eth'),
354                );
355
356     my @warnings;
357     local $SIG{__WARN__} = sub {
358         push @warnings, @_;
359     };
360
361     foreach my $left (qw(plain object1 object2)) {
362         foreach my $right (qw(plain object1 object2)) {
363             @warnings = ();
364             $! = 0;
365             is eval {copy $what{$left}, $what{$right}}, 1, "copy $left $right";
366             is $@, '', 'No croaking';
367             is $!, '', 'No system call errors';
368             is @warnings, 1, 'Exactly 1 warning';
369             like $warnings[0],
370                 qr/'$object' and '$object' are identical \(not copied\)/,
371                     'with the text we expect';
372         }
373     }
374 }
375
376 END {
377     1 while unlink "file-$$";
378     1 while unlink "lib/file-$$";
379 }