Commit | Line | Data |
---|---|---|
1a3850a5 GA |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
f8afb667 NC |
4 | if( $ENV{PERL_CORE} ) { |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | } | |
1a3850a5 GA |
8 | } |
9 | ||
d9641052 | 10 | use Test::More; |
1a3850a5 | 11 | |
d9641052 NC |
12 | my $TB = Test::More->builder; |
13 | ||
d6464aae NC |
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 | ||
1a04d035 | 20 | |
1a3850a5 | 21 | use File::Copy; |
a07fbdca | 22 | use Config; |
1a3850a5 | 23 | |
d6464aae NC |
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; | |
f8afb667 | 30 | like $@, qr/^Usage: /, "'$code' is a usage error"; |
d6464aae NC |
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 | } | |
1a04d035 A |
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 | |
d9641052 | 45 | printf F "ok\n"; |
1a04d035 A |
46 | close F; |
47 | ||
48 | copy "file-$$", "copy-$$"; | |
49 | ||
50 | open(F, "copy-$$") or die; | |
51 | $foo = <F>; | |
52 | close(F); | |
53 | ||
f8afb667 | 54 | is -s "file-$$", -s "copy-$$", 'copy(fn, fn): files of the same size'; |
1a04d035 | 55 | |
f8afb667 | 56 | is $foo, "ok\n", 'copy(fn, fn): same contents'; |
1a04d035 | 57 | |
f8afb667 | 58 | print("# next test checks copying to STDOUT\n"); |
1a04d035 | 59 | binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode |
d9641052 | 60 | # This outputs "ok" so its a test. |
1a04d035 | 61 | copy "copy-$$", \*STDOUT; |
d9641052 | 62 | $TB->current_test($TB->current_test + 1); |
1a04d035 A |
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); | |
f8afb667 | 68 | is $foo, "ok\n", 'copy(*F, fn): same contents'; |
1a04d035 | 69 | unlink "copy-$$" or die "unlink: $!"; |
d9641052 | 70 | |
1a04d035 A |
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: $!"; | |
f8afb667 | 75 | is $foo, "ok\n", 'copy(\*F, fn): same contents'; |
1a04d035 A |
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); | |
f8afb667 | 84 | is $foo, "ok\n", 'copy(fn, io): same contents'; |
1a04d035 | 85 | unlink "copy-$$" or die "unlink: $!"; |
d9641052 | 86 | |
1a04d035 A |
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); | |
f8afb667 | 93 | is $foo, "ok\n", 'copy(fn, fh): same contents'; |
1a04d035 A |
94 | unlink "file-$$" or die "unlink: $!"; |
95 | ||
d9641052 NC |
96 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
97 | ok -e "copy-$$", ' target still there'; | |
1a04d035 | 98 | |
d6464aae NC |
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'; | |
d9641052 NC |
109 | ok -e "file-$$", ' destination exists'; |
110 | ok !-e "copy-$$", ' source does not'; | |
1a04d035 | 111 | open(R, "file-$$") or die; $foo = <R>; close(R); |
f8afb667 | 112 | is $foo, "ok\n", 'contents preserved'; |
d9641052 | 113 | |
f69f56d6 NC |
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 | } | |
d6464aae | 122 | |
f8afb667 NC |
123 | # trick: create lib/ if not exists - not needed in Perl core |
124 | unless (-d 'lib') { mkdir 'lib' or die; } | |
d9641052 | 125 | copy "file-$$", "lib"; |
f8afb667 NC |
126 | open(R, "lib/file-$$") or die $!; $foo = <R>; close(R); |
127 | is $foo, "ok\n", 'copy(fn, dir): same contents'; | |
d9641052 NC |
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); | |
f8afb667 | 133 | is $foo, "ok\n", 'copy over the same file works'; |
d9641052 NC |
134 | unlink "lib/file-$$" or die "unlink: $!"; |
135 | ||
d6464aae NC |
136 | { |
137 | my $warnings = ''; | |
138 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
f8afb667 | 139 | ok copy("file-$$", "file-$$"), 'copy(fn, fn) succeeds'; |
d6464aae | 140 | |
f8afb667 NC |
141 | like $warnings, qr/are identical/, 'but warns'; |
142 | ok -s "file-$$", 'contents preserved'; | |
d6464aae | 143 | } |
d9641052 NC |
144 | |
145 | move "file-$$", "lib"; | |
146 | open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); | |
f8afb667 NC |
147 | is $foo, "ok\n", 'move(fn, dir): same contents'; |
148 | ok !-e "file-$$", 'file moved indeed'; | |
d9641052 NC |
149 | unlink "lib/file-$$" or die "unlink: $!"; |
150 | ||
151 | SKIP: { | |
d6464aae | 152 | skip "Testing symlinks", 3 unless $Config{d_symlink}; |
a07fbdca | 153 | |
a07fbdca SR |
154 | open(F, ">file-$$") or die $!; |
155 | print F "dummy content\n"; | |
156 | close F; | |
157 | symlink("file-$$", "symlink-$$") or die $!; | |
d6464aae NC |
158 | |
159 | my $warnings = ''; | |
160 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
f8afb667 | 161 | ok !copy("file-$$", "symlink-$$"), 'copy to itself (via symlink) fails'; |
d6464aae | 162 | |
f8afb667 | 163 | like $warnings, qr/are identical/, 'emits a warning'; |
d9641052 NC |
164 | ok !-z "file-$$", |
165 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
166 | ||
a07fbdca SR |
167 | unlink "symlink-$$"; |
168 | unlink "file-$$"; | |
6c254d95 | 169 | } |
a07fbdca | 170 | |
d9641052 | 171 | SKIP: { |
f8afb667 NC |
172 | skip "Testing hard links", 3 |
173 | if !$Config{d_link} or $^O eq 'MSWin32' or $^O eq 'cygwin'; | |
d9641052 NC |
174 | |
175 | open(F, ">file-$$") or die $!; | |
176 | print F "dummy content\n"; | |
177 | close F; | |
178 | link("file-$$", "hardlink-$$") or die $!; | |
d6464aae NC |
179 | |
180 | my $warnings = ''; | |
181 | local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; | |
f8afb667 | 182 | ok !copy("file-$$", "hardlink-$$"), 'copy to itself (via hardlink) fails'; |
d6464aae | 183 | |
f8afb667 | 184 | like $warnings, qr/are identical/, 'emits a warning'; |
d9641052 NC |
185 | ok ! -z "file-$$", |
186 | 'rt.perl.org 5196: copying to itself would truncate the file'; | |
187 | ||
188 | unlink "hardlink-$$"; | |
189 | unlink "file-$$"; | |
a07fbdca | 190 | } |
1a04d035 A |
191 | } |
192 | ||
441496b2 | 193 | |
cfcb0b09 JH |
194 | END { |
195 | 1 while unlink "file-$$"; | |
d9641052 | 196 | 1 while unlink "lib/file-$$"; |
cfcb0b09 | 197 | } |