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