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 | |
1ef59467 |
12 | plan tests => 48; |
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 | |
1ef59467 |
22 | for my $cross_partition_test (0..1) { |
23 | { |
24 | # Simulate a cross-partition copy/move by forcing rename to |
25 | # fail. |
26 | no warnings 'redefine'; |
27 | *CORE::GLOBAL::rename = sub { 0 } if $cross_partition_test; |
28 | } |
1a04d035 |
29 | |
30 | # First we create a file |
31 | open(F, ">file-$$") or die; |
32 | binmode F; # for DOSISH platforms, because test 3 copies to stdout |
83519ebf |
33 | printf F "ok\n"; |
1a04d035 |
34 | close F; |
35 | |
36 | copy "file-$$", "copy-$$"; |
37 | |
38 | open(F, "copy-$$") or die; |
39 | $foo = <F>; |
40 | close(F); |
41 | |
83519ebf |
42 | is -s "file-$$", -s "copy-$$"; |
1a04d035 |
43 | |
83519ebf |
44 | is $foo, "ok\n"; |
1a04d035 |
45 | |
46 | binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode |
83519ebf |
47 | # This outputs "ok" so its a test. |
1a04d035 |
48 | copy "copy-$$", \*STDOUT; |
83519ebf |
49 | $TB->current_test($TB->current_test + 1); |
1a04d035 |
50 | unlink "copy-$$" or die "unlink: $!"; |
51 | |
52 | open(F,"file-$$"); |
53 | copy(*F, "copy-$$"); |
54 | open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); |
83519ebf |
55 | is $foo, "ok\n"; |
1a04d035 |
56 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf |
57 | |
1a04d035 |
58 | open(F,"file-$$"); |
59 | copy(\*F, "copy-$$"); |
60 | close(F) or die "close: $!"; |
61 | open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; |
83519ebf |
62 | is $foo, "ok\n"; |
1a04d035 |
63 | unlink "copy-$$" or die "unlink: $!"; |
64 | |
65 | require IO::File; |
66 | $fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
67 | binmode $fh or die; |
68 | copy("file-$$",$fh); |
69 | $fh->close or die "close: $!"; |
70 | open(R, "copy-$$") or die; $foo = <R>; close(R); |
83519ebf |
71 | is $foo, "ok\n"; |
1a04d035 |
72 | unlink "copy-$$" or die "unlink: $!"; |
83519ebf |
73 | |
1a04d035 |
74 | require FileHandle; |
75 | my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; |
76 | binmode $fh or die; |
77 | copy("file-$$",$fh); |
78 | $fh->close; |
79 | open(R, "copy-$$") or die; $foo = <R>; close(R); |
83519ebf |
80 | is $foo, "ok\n"; |
1a04d035 |
81 | unlink "file-$$" or die "unlink: $!"; |
82 | |
83519ebf |
83 | ok !move("file-$$", "copy-$$"), "move on missing file"; |
84 | ok -e "copy-$$", ' target still there'; |
1a04d035 |
85 | |
1ef59467 |
86 | # Doesn't really matter what time it is as long as its not now. |
87 | my $time = 1000000000; |
88 | utime( $time, $time, "copy-$$" ); |
89 | |
90 | # Recheck the mtime rather than rely on utime in case we're on a |
91 | # system where utime doesn't work or there's no mtime at all. |
92 | # The destination file will reflect the same difficulties. |
93 | my $mtime = (stat("copy-$$"))[9]; |
94 | |
83519ebf |
95 | ok move "copy-$$", "file-$$", 'move'; |
96 | ok -e "file-$$", ' destination exists'; |
97 | ok !-e "copy-$$", ' source does not'; |
1a04d035 |
98 | open(R, "file-$$") or die; $foo = <R>; close(R); |
83519ebf |
99 | is $foo, "ok\n"; |
100 | |
1ef59467 |
101 | my $dest_mtime = (stat("file-$$"))[9]; |
102 | is $dest_mtime, $mtime, |
103 | "mtime preserved by copy()". |
104 | ($cross_partition_test ? " while testing cross-partition" : ""); |
105 | |
83519ebf |
106 | copy "file-$$", "lib"; |
107 | open(R, "lib/file-$$") or die; $foo = <R>; close(R); |
108 | is $foo, "ok\n"; |
109 | unlink "lib/file-$$" or die "unlink: $!"; |
110 | |
111 | # Do it twice to ensure copying over the same file works. |
112 | copy "file-$$", "lib"; |
113 | open(R, "lib/file-$$") or die; $foo = <R>; close(R); |
114 | is $foo, "ok\n"; |
115 | unlink "lib/file-$$" or die "unlink: $!"; |
116 | |
117 | eval { copy("file-$$", "file-$$") }; |
118 | like $@, qr/are identical/; |
119 | ok -s "file-$$"; |
120 | |
121 | move "file-$$", "lib"; |
122 | open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); |
123 | is $foo, "ok\n"; |
124 | ok !-e "file-$$"; |
125 | unlink "lib/file-$$" or die "unlink: $!"; |
126 | |
127 | SKIP: { |
128 | skip "Testing symlinks", 2 unless $Config{d_symlink}; |
ac7b122d |
129 | |
ac7b122d |
130 | open(F, ">file-$$") or die $!; |
131 | print F "dummy content\n"; |
132 | close F; |
133 | symlink("file-$$", "symlink-$$") or die $!; |
134 | eval { copy("file-$$", "symlink-$$") }; |
83519ebf |
135 | like $@, qr/are identical/; |
136 | ok !-z "file-$$", |
137 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
138 | |
ac7b122d |
139 | unlink "symlink-$$"; |
140 | unlink "file-$$"; |
6c254d95 |
141 | } |
ac7b122d |
142 | |
83519ebf |
143 | SKIP: { |
144 | skip "Testing hard links", 2 if !$Config{d_link} or $^O eq 'MSWin32'; |
145 | |
146 | open(F, ">file-$$") or die $!; |
147 | print F "dummy content\n"; |
148 | close F; |
149 | link("file-$$", "hardlink-$$") or die $!; |
150 | eval { copy("file-$$", "hardlink-$$") }; |
151 | like $@, qr/are identical/; |
152 | ok ! -z "file-$$", |
153 | 'rt.perl.org 5196: copying to itself would truncate the file'; |
154 | |
155 | unlink "hardlink-$$"; |
156 | unlink "file-$$"; |
ac7b122d |
157 | } |
1a04d035 |
158 | } |
159 | |
441496b2 |
160 | |
cfcb0b09 |
161 | END { |
162 | 1 while unlink "file-$$"; |
83519ebf |
163 | 1 while unlink "lib/file-$$"; |
cfcb0b09 |
164 | } |