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