Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / lfs.t
CommitLineData
ea2b5ef6 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 5BEGIN {
ea2b5ef6 6 chdir 't' if -d 't';
20822f61 7 @INC = '../lib';
9f8fdb7d 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 14}
15
326fd4b6 16use strict;
52ece81a 17
326fd4b6 18our @s;
19our $fail;
20
93c29725 21sub zap {
6da84e39 22 close(BIG);
93c29725 23 unlink("big");
24 unlink("big1");
25 unlink("big2");
26}
27
28sub bye {
29 zap();
6da84e39 30 exit(0);
31}
32
d731b481 33my $explained;
34
fcbfa962 35sub explain {
d731b481 36 unless ($explained++) {
37 print <<EOM;
fcbfa962 38#
d731b481 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 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 51#
52EOM
d731b481 53 }
54 print "1..0 # Skip: @_\n" if @_;
fcbfa962 55}
56
0ecd3ba2 57$| = 1;
58
e0a10278 59print "# checking whether we have sparse files...\n";
60
05f8a9f5 61# Known have-nots.
2986a63f 62if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
86e48eb5 63 print "1..0 # Skip: no sparse files in $^O\n";
6da84e39 64 bye();
65}
66
b18f8161 67# Known haves that have problems running this test
68# (for example because they do not support sparse files, like UNICOS)
69if ($^O eq 'unicos') {
972720f9 70 print "1..0 # Skip: no sparse files in $^O, unable to test large files\n";
b18f8161 71 bye();
72}
73
e0a10278 74# Then try to heuristically deduce whether we have sparse files.
05f8a9f5 75
64215065 76# Let's not depend on Fcntl or any other extension.
77
ea2b5ef6 78my ($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 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 85open(BIG, ">big1") or
86 do { warn "open big1 failed: $!\n"; bye };
87binmode(BIG) or
88 do { warn "binmode big1 failed: $!\n"; bye };
89seek(BIG, 1_000_000, $SEEK_SET) or
90 do { warn "seek big1 failed: $!\n"; bye };
91print BIG "big" or
92 do { warn "print big1 failed: $!\n"; bye };
93close(BIG) or
94 do { warn "close big1 failed: $!\n"; bye };
95
96my @s1 = stat("big1");
97
98print "# s1 = @s1\n";
99
100open(BIG, ">big2") or
101 do { warn "open big2 failed: $!\n"; bye };
102binmode(BIG) or
103 do { warn "binmode big2 failed: $!\n"; bye };
104seek(BIG, 2_000_000, $SEEK_SET) or
105 do { warn "seek big2 failed; $!\n"; bye };
106print BIG "big" or
107 do { warn "print big2 failed; $!\n"; bye };
108close(BIG) or
109 do { warn "close big2 failed; $!\n"; bye };
110
111my @s2 = stat("big2");
112
113print "# s2 = @s2\n";
114
115zap();
116
117unless ($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 121}
122
e0a10278 123print "# we seem to have sparse files...\n";
124
817e2dcb 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 129$ENV{LC_ALL} = "C";
130
6afb513c 131my $r = system '../perl', '-e', <<'EOF';
132open(BIG, ">big");
133seek(BIG, 5_000_000_000, 0);
134print BIG "big";
135exit 0;
136EOF
137
ea2b5ef6 138open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
817e2dcb 139binmode BIG;
6afb513c 140if ($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 143 bye();
144}
eed7fde4 145
fcbfa962 146# Either the print or (more likely, thanks to buffering) the close will
147# fail if there are are filesize limitations (process or fs).
148my $print = print BIG "big";
e0a10278 149print "# print failed: $!\n" unless $print;
150my $close = close BIG;
151print "# close failed: $!\n" unless $close;
fcbfa962 152unless ($print && $close) {
b948423f 153 if ($! =~/too large/i) {
d731b481 154 explain("writing past 2GB failed: process limits?");
b948423f 155 } elsif ($! =~ /quota/i) {
d731b481 156 explain("filesystem quota limits?");
157 } else {
158 explain("error: $!");
fcbfa962 159 }
160 bye();
161}
817e2dcb 162
163@s = stat("big");
164
ea2b5ef6 165print "# @s\n";
166
ae178db1 167unless ($s[7] == 5_000_000_003) {
d731b481 168 explain("kernel/fs not configured to use large files?");
ae178db1 169 bye();
170}
171
05f8a9f5 172sub fail () {
64215065 173 print "not ";
05f8a9f5 174 $fail++;
175}
176
326fd4b6 177sub 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 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 194 fail;
195 }
196}
197
77166d51 198print "1..17\n";
fcbfa962 199
52ece81a 200$fail = 0;
fcbfa962 201
64215065 202fail unless $s[7] == 5_000_000_003; # exercizes pp_stat
817e2dcb 203print "ok 1\n";
204
64215065 205fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize
817e2dcb 206print "ok 2\n";
207
77166d51 208fail unless -e "big";
209print "ok 3\n";
210
211fail unless -f "big";
212print "ok 4\n";
213
ea2b5ef6 214open(BIG, "big") or do { warn "open failed: $!\n"; bye };
817e2dcb 215binmode BIG;
216
77166d51 217fail unless seek(BIG, 4_500_000_000, $SEEK_SET);
218print "ok 5\n";
817e2dcb 219
326fd4b6 220offset('tell(BIG)', 4_500_000_000);
77166d51 221print "ok 6\n";
817e2dcb 222
77166d51 223fail unless seek(BIG, 1, $SEEK_CUR);
224print "ok 7\n";
817e2dcb 225
326fd4b6 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.
229offset('tell(BIG)', 4_500_000_001);
77166d51 230print "ok 8\n";
817e2dcb 231
77166d51 232fail unless seek(BIG, -1, $SEEK_CUR);
233print "ok 9\n";
817e2dcb 234
326fd4b6 235offset('tell(BIG)', 4_500_000_000);
77166d51 236print "ok 10\n";
817e2dcb 237
77166d51 238fail unless seek(BIG, -3, $SEEK_END);
239print "ok 11\n";
817e2dcb 240
326fd4b6 241offset('tell(BIG)', 5_000_000_000);
77166d51 242print "ok 12\n";
817e2dcb 243
244my $big;
245
05f8a9f5 246fail unless read(BIG, $big, 3) == 3;
77166d51 247print "ok 13\n";
817e2dcb 248
05f8a9f5 249fail unless $big eq "big";
77166d51 250print "ok 14\n";
251
252# 705_032_704 = (I32)5_000_000_000
326fd4b6 253# See that we don't have "big" in the 705_... spot:
254# that would mean that we have a wraparound.
77166d51 255fail unless seek(BIG, 705_032_704, $SEEK_SET);
256print "ok 15\n";
257
258my $zero;
259
260fail unless read(BIG, $zero, 3) == 3;
261print "ok 16\n";
262
263fail unless $zero eq "\0\0\0";
264print "ok 17\n";
817e2dcb 265
d731b481 266explain() if $fail;
05f8a9f5 267
77166d51 268bye(); # does the necessary cleanup
e9a694fc 269
290be4b1 270END {
b0d0c539 271 # unlink may fail if applied directly to a large file
6c8d78fb 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 276}
277
6da84e39 278# eof