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