Commit | Line | Data |
---|---|---|
ea2b5ef6 JH |
1 | # NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio). |
2 | # sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. | |
4d0ed6f7 | 3 | # If you modify/add tests here, remember to update also ext/Fcntl/t/syslfs.t. |
ea2b5ef6 | 4 | |
817e2dcb | 5 | BEGIN { |
ea2b5ef6 | 6 | chdir 't' if -d 't'; |
20822f61 | 7 | @INC = '../lib'; |
9f8fdb7d JH |
8 | # Don't bother if there are no quad offsets. |
9 | require Config; import Config; | |
10 | if ($Config{lseeksize} < 8) { | |
6afb513c | 11 | print "1..0 # Skip: no 64-bit file offsets\n"; |
48ea9154 | 12 | exit(0); |
9f8fdb7d | 13 | } |
1c25d394 | 14 | require './test.pl'; |
817e2dcb JH |
15 | } |
16 | ||
326fd4b6 | 17 | use strict; |
52ece81a | 18 | |
326fd4b6 A |
19 | our @s; |
20 | our $fail; | |
21 | ||
1c25d394 NC |
22 | my $big0 = tempfile(); |
23 | my $big1 = tempfile(); | |
24 | my $big2 = tempfile(); | |
25 | ||
93c29725 | 26 | sub zap { |
6da84e39 | 27 | close(BIG); |
93c29725 JH |
28 | } |
29 | ||
30 | sub bye { | |
31 | zap(); | |
6da84e39 JH |
32 | exit(0); |
33 | } | |
34 | ||
d731b481 JH |
35 | my $explained; |
36 | ||
fcbfa962 | 37 | sub explain { |
d731b481 JH |
38 | unless ($explained++) { |
39 | print <<EOM; | |
fcbfa962 | 40 | # |
d731b481 JH |
41 | # If the lfs (large file support: large meaning larger than two |
42 | # gigabytes) tests are skipped or fail, it may mean either that your | |
43 | # process (or process group) is not allowed to write large files | |
44 | # (resource limits) or that the file system (the network filesystem?) | |
45 | # you are running the tests on doesn't let your user/group have large | |
46 | # files (quota) or the filesystem simply doesn't support large files. | |
47 | # You may even need to reconfigure your kernel. (This is all very | |
48 | # operating system and site-dependent.) | |
fcbfa962 JH |
49 | # |
50 | # Perl may still be able to support large files, once you have | |
eed7fde4 | 51 | # such a process, enough quota, and such a (file) system. |
d731b481 | 52 | # It is just that the test failed now. |
fcbfa962 JH |
53 | # |
54 | EOM | |
d731b481 JH |
55 | } |
56 | print "1..0 # Skip: @_\n" if @_; | |
fcbfa962 JH |
57 | } |
58 | ||
0ecd3ba2 MG |
59 | $| = 1; |
60 | ||
e0a10278 JH |
61 | print "# checking whether we have sparse files...\n"; |
62 | ||
05f8a9f5 | 63 | # Known have-nots. |
2986a63f | 64 | if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { |
86e48eb5 | 65 | print "1..0 # Skip: no sparse files in $^O\n"; |
6da84e39 JH |
66 | bye(); |
67 | } | |
68 | ||
b18f8161 JH |
69 | # Known haves that have problems running this test |
70 | # (for example because they do not support sparse files, like UNICOS) | |
71 | if ($^O eq 'unicos') { | |
972720f9 | 72 | print "1..0 # Skip: no sparse files in $^O, unable to test large files\n"; |
b18f8161 JH |
73 | bye(); |
74 | } | |
75 | ||
e0a10278 | 76 | # Then try to heuristically deduce whether we have sparse files. |
05f8a9f5 | 77 | |
64215065 JH |
78 | # Let's not depend on Fcntl or any other extension. |
79 | ||
ea2b5ef6 | 80 | my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); |
6da84e39 | 81 | |
ea2b5ef6 | 82 | # We'll start off by creating a one megabyte file which has |
05f8a9f5 JH |
83 | # only three "true" bytes. If we have sparseness, we should |
84 | # consume less blocks than one megabyte (assuming nobody has | |
85 | # one megabyte blocks...) | |
817e2dcb | 86 | |
1c25d394 NC |
87 | open(BIG, ">$big1") or |
88 | do { warn "open $big1 failed: $!\n"; bye }; | |
93c29725 | 89 | binmode(BIG) or |
1c25d394 | 90 | do { warn "binmode $big1 failed: $!\n"; bye }; |
93c29725 | 91 | seek(BIG, 1_000_000, $SEEK_SET) or |
1c25d394 | 92 | do { warn "seek $big1 failed: $!\n"; bye }; |
93c29725 | 93 | print BIG "big" or |
1c25d394 | 94 | do { warn "print $big1 failed: $!\n"; bye }; |
93c29725 | 95 | close(BIG) or |
1c25d394 | 96 | do { warn "close $big1 failed: $!\n"; bye }; |
93c29725 | 97 | |
1c25d394 | 98 | my @s1 = stat($big1); |
93c29725 JH |
99 | |
100 | print "# s1 = @s1\n"; | |
101 | ||
1c25d394 NC |
102 | open(BIG, ">$big2") or |
103 | do { warn "open $big2 failed: $!\n"; bye }; | |
93c29725 | 104 | binmode(BIG) or |
1c25d394 | 105 | do { warn "binmode $big2 failed: $!\n"; bye }; |
93c29725 | 106 | seek(BIG, 2_000_000, $SEEK_SET) or |
1c25d394 | 107 | do { warn "seek $big2 failed; $!\n"; bye }; |
93c29725 | 108 | print BIG "big" or |
1c25d394 | 109 | do { warn "print $big2 failed; $!\n"; bye }; |
93c29725 | 110 | close(BIG) or |
1c25d394 | 111 | do { warn "close $big2 failed; $!\n"; bye }; |
93c29725 | 112 | |
1c25d394 | 113 | my @s2 = stat($big2); |
93c29725 JH |
114 | |
115 | print "# s2 = @s2\n"; | |
116 | ||
117 | zap(); | |
118 | ||
119 | unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && | |
411c7dd7 LB |
120 | $s1[11] == $s2[11] && $s1[12] == $s2[12] && |
121 | $s1[12] > 0) { | |
6afb513c | 122 | print "1..0 # Skip: no sparse files?\n"; |
93c29725 | 123 | bye; |
817e2dcb JH |
124 | } |
125 | ||
e0a10278 JH |
126 | print "# we seem to have sparse files...\n"; |
127 | ||
817e2dcb JH |
128 | # By now we better be sure that we do have sparse files: |
129 | # if we are not, the following will hog 5 gigabytes of disk. Ooops. | |
6afb513c | 130 | # This may fail by producing some signal; run in a subprocess first for safety |
817e2dcb | 131 | |
eed7fde4 JH |
132 | $ENV{LC_ALL} = "C"; |
133 | ||
6afb513c | 134 | my $r = system '../perl', '-e', <<'EOF'; |
1c25d394 | 135 | open(BIG, ">$big0"); |
6afb513c | 136 | seek(BIG, 5_000_000_000, 0); |
1c25d394 | 137 | print BIG $big0; |
6afb513c MG |
138 | exit 0; |
139 | EOF | |
140 | ||
1c25d394 | 141 | open(BIG, ">$big0") or do { warn "open failed: $!\n"; bye }; |
817e2dcb | 142 | binmode BIG; |
6afb513c MG |
143 | if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { |
144 | my $err = $r ? 'signal '.($r & 0x7f) : $!; | |
d731b481 | 145 | explain("seeking past 2GB failed: $err"); |
e0a10278 JH |
146 | bye(); |
147 | } | |
eed7fde4 | 148 | |
fcbfa962 JH |
149 | # Either the print or (more likely, thanks to buffering) the close will |
150 | # fail if there are are filesize limitations (process or fs). | |
151 | my $print = print BIG "big"; | |
e0a10278 JH |
152 | print "# print failed: $!\n" unless $print; |
153 | my $close = close BIG; | |
154 | print "# close failed: $!\n" unless $close; | |
fcbfa962 | 155 | unless ($print && $close) { |
b948423f | 156 | if ($! =~/too large/i) { |
d731b481 | 157 | explain("writing past 2GB failed: process limits?"); |
b948423f | 158 | } elsif ($! =~ /quota/i) { |
d731b481 JH |
159 | explain("filesystem quota limits?"); |
160 | } else { | |
161 | explain("error: $!"); | |
fcbfa962 JH |
162 | } |
163 | bye(); | |
164 | } | |
817e2dcb | 165 | |
1c25d394 | 166 | @s = stat($big0); |
817e2dcb | 167 | |
ea2b5ef6 JH |
168 | print "# @s\n"; |
169 | ||
ae178db1 | 170 | unless ($s[7] == 5_000_000_003) { |
d731b481 | 171 | explain("kernel/fs not configured to use large files?"); |
ae178db1 JH |
172 | bye(); |
173 | } | |
174 | ||
1c25d394 | 175 | sub fail { |
64215065 | 176 | print "not "; |
05f8a9f5 JH |
177 | $fail++; |
178 | } | |
179 | ||
326fd4b6 A |
180 | sub offset ($$) { |
181 | my ($offset_will_be, $offset_want) = @_; | |
182 | my $offset_is = eval $offset_will_be; | |
183 | unless ($offset_is == $offset_want) { | |
184 | print "# bad offset $offset_is, want $offset_want\n"; | |
52ece81a | 185 | my ($offset_func) = ($offset_will_be =~ /^(\w+)/); |
326fd4b6 | 186 | if (unpack("L", pack("L", $offset_want)) == $offset_is) { |
326fd4b6 | 187 | print "# 32-bit wraparound suspected in $offset_func() since\n"; |
52ece81a | 188 | print "# $offset_want cast into 32 bits equals $offset_is.\n"; |
f06a04a3 | 189 | } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 |
52ece81a | 190 | == $offset_is) { |
f06a04a3 A |
191 | print "# 32-bit wraparound suspected in $offset_func() since\n"; |
192 | printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", | |
193 | $offset_want, | |
194 | $offset_want, | |
195 | $offset_is; | |
196 | } | |
326fd4b6 A |
197 | fail; |
198 | } | |
199 | } | |
200 | ||
77166d51 | 201 | print "1..17\n"; |
fcbfa962 | 202 | |
52ece81a | 203 | $fail = 0; |
fcbfa962 | 204 | |
64215065 | 205 | fail unless $s[7] == 5_000_000_003; # exercizes pp_stat |
817e2dcb JH |
206 | print "ok 1\n"; |
207 | ||
1c25d394 | 208 | fail unless -s $big0 == 5_000_000_003; # exercizes pp_ftsize |
817e2dcb JH |
209 | print "ok 2\n"; |
210 | ||
1c25d394 | 211 | fail unless -e $big0; |
77166d51 JH |
212 | print "ok 3\n"; |
213 | ||
1c25d394 | 214 | fail unless -f $big0; |
77166d51 JH |
215 | print "ok 4\n"; |
216 | ||
1c25d394 | 217 | open(BIG, $big0) or do { warn "open failed: $!\n"; bye }; |
817e2dcb JH |
218 | binmode BIG; |
219 | ||
77166d51 JH |
220 | fail unless seek(BIG, 4_500_000_000, $SEEK_SET); |
221 | print "ok 5\n"; | |
817e2dcb | 222 | |
326fd4b6 | 223 | offset('tell(BIG)', 4_500_000_000); |
77166d51 | 224 | print "ok 6\n"; |
817e2dcb | 225 | |
77166d51 JH |
226 | fail unless seek(BIG, 1, $SEEK_CUR); |
227 | print "ok 7\n"; | |
817e2dcb | 228 | |
326fd4b6 A |
229 | # If you get 205_032_705 from here it means that |
230 | # your tell() is returning 32-bit values since (I32)4_500_000_001 | |
231 | # is exactly 205_032_705. | |
232 | offset('tell(BIG)', 4_500_000_001); | |
77166d51 | 233 | print "ok 8\n"; |
817e2dcb | 234 | |
77166d51 JH |
235 | fail unless seek(BIG, -1, $SEEK_CUR); |
236 | print "ok 9\n"; | |
817e2dcb | 237 | |
326fd4b6 | 238 | offset('tell(BIG)', 4_500_000_000); |
77166d51 | 239 | print "ok 10\n"; |
817e2dcb | 240 | |
77166d51 JH |
241 | fail unless seek(BIG, -3, $SEEK_END); |
242 | print "ok 11\n"; | |
817e2dcb | 243 | |
326fd4b6 | 244 | offset('tell(BIG)', 5_000_000_000); |
77166d51 | 245 | print "ok 12\n"; |
817e2dcb JH |
246 | |
247 | my $big; | |
248 | ||
05f8a9f5 | 249 | fail unless read(BIG, $big, 3) == 3; |
77166d51 | 250 | print "ok 13\n"; |
817e2dcb | 251 | |
05f8a9f5 | 252 | fail unless $big eq "big"; |
77166d51 JH |
253 | print "ok 14\n"; |
254 | ||
255 | # 705_032_704 = (I32)5_000_000_000 | |
326fd4b6 A |
256 | # See that we don't have "big" in the 705_... spot: |
257 | # that would mean that we have a wraparound. | |
77166d51 JH |
258 | fail unless seek(BIG, 705_032_704, $SEEK_SET); |
259 | print "ok 15\n"; | |
260 | ||
261 | my $zero; | |
262 | ||
263 | fail unless read(BIG, $zero, 3) == 3; | |
264 | print "ok 16\n"; | |
265 | ||
266 | fail unless $zero eq "\0\0\0"; | |
267 | print "ok 17\n"; | |
817e2dcb | 268 | |
d731b481 | 269 | explain() if $fail; |
05f8a9f5 | 270 | |
77166d51 | 271 | bye(); # does the necessary cleanup |
e9a694fc | 272 | |
290be4b1 | 273 | END { |
b0d0c539 | 274 | # unlink may fail if applied directly to a large file |
6c8d78fb | 275 | # be paranoid about leaving 5 gig files lying around |
1c25d394 | 276 | open(BIG, ">$big0"); # truncate |
b0d0c539 | 277 | close(BIG); |
290be4b1 JH |
278 | } |
279 | ||
6da84e39 | 280 | # eof |