4 if( $ENV{PERL_CORE} ) {
12 my $TB = Test::More->builder;
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]) }; }
25 foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
26 "move()", "move('arg')", "move('arg', 'arg', 'arg')"
30 like $@, qr/^Usage: /, "'$code' is a usage error";
34 for my $cross_partition_test (0..1) {
36 # Simulate a cross-partition copy/move by forcing rename to
38 no warnings 'redefine';
39 *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test;
42 # First we create a file
43 open(F, ">file-$$") or die;
44 binmode F; # for DOSISH platforms, because test 3 copies to stdout
48 copy "file-$$", "copy-$$";
50 open(F, "copy-$$") or die;
54 is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size';
56 is $foo, "ok\n", 'copy(fn, fn): same contents';
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: $!";
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: $!";
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: $!";
79 $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
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: $!";
88 my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
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: $!";
96 ok !move("file-$$", "copy-$$"), "move on missing file";
97 ok -e "copy-$$", ' target still there';
99 # Doesn't really matter what time it is as long as its not now.
100 my $time = 1000000000;
101 utime( $time, $time, "copy-$$" );
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];
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';
115 local $TODO = 'mtime only preserved on ODS-5 with POSIX dates and DECC$EFS_FILE_TIMESTAMPS enabled' if $^O eq 'VMS';
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" : "");
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: $!";
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: $!";
138 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
139 ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds';
141 like $warnings, qr/are identical/, 'but warns';
142 ok -s "file-$$", 'contents preserved';
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: $!";
152 skip "Testing symlinks", 3 unless $Config{d_symlink};
154 open(F, ">file-$$") or die $!;
155 print F "dummy content\n";
157 symlink("file-$$", "symlink-$$") or die $!;
160 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
161 ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails';
163 like $warnings, qr/are identical/, 'emits a warning';
165 'rt.perl.org 5196: copying to itself would truncate the file';
172 skip "Testing hard links", 3
173 if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin';
175 open(F, ">file-$$") or die $!;
176 print F "dummy content\n";
178 link("file-$$", "hardlink-$$") or die $!;
181 local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
182 ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails';
184 like $warnings, qr/are identical/, 'emits a warning';
186 'rt.perl.org 5196: copying to itself would truncate the file';
188 unlink "hardlink-$$";
195 1 while unlink "file-$$";
196 1 while unlink "lib/file-$$";