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