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