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