This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Fcntl's syslfs.t and t/op/lfs.t, eliminate bye().
[perl5.git] / ext / Fcntl / t / syslfs.t
1 # NOTE: this file tests how large files (>2GB) work with raw system IO.
2 # stdio: open(), tell(), seek(), print(), read() is tested in t/op/lfs.t.
3 # If you modify/add tests here, remember to update also t/op/lfs.t.
4
5 BEGIN {
6         require Config; import Config;
7         # Don't bother if there are no quad offsets.
8         if ($Config{lseeksize} < 8) {
9                 print "1..0 # Skip: no 64-bit file offsets\n";
10                 exit(0);
11         }
12         require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);
13 }
14
15 use strict;
16 use File::Temp 'tempfile';
17
18 our @s;
19 our $fail;
20
21 (undef, my $big0) = tempfile(UNLINK => 1);
22 (undef, my $big1) = tempfile(UNLINK => 1);
23 (undef, my $big2) = tempfile(UNLINK => 1);
24
25 my $explained;
26
27 sub explain {
28     unless ($explained++) {
29         print <<EOM;
30 #
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.)
39 #
40 # Perl may still be able to support large files, once you have
41 # such a process, enough quota, and such a (file) system.
42 # It is just that the test failed now.
43 #
44 EOM
45     }
46     if (@_) {
47         print "1..0 # Skip: @_\n";
48         exit 0;
49     }
50 }
51
52 $| = 1;
53
54 print "# checking whether we have sparse files...\n";
55
56 # Known have-nots.
57 if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
58     print "1..0 # Skip: no sparse files in $^O\n";
59     exit 0;
60 }
61
62 # Known haves that have problems running this test
63 # (for example because they do not support sparse files, like UNICOS)
64 if ($^O eq 'unicos') {
65     print "1..0 # Skip: no sparse files in $^O, unable to test large files\n";
66     exit 0;
67 }
68
69 # Then try heuristically to deduce whether we have sparse files.
70
71 # We'll start off by creating a one megabyte file which has
72 # only three "true" bytes.  If we have sparseness, we should
73 # consume less blocks than one megabyte (assuming nobody has
74 # one megabyte blocks...)
75
76 sysopen(BIG, $big1, O_WRONLY|O_CREAT|O_TRUNC) or
77     die "sysopen $big1 failed: $!";
78 sysseek(BIG, 1_000_000, SEEK_SET) or
79     die "sysseek $big1 failed: $!";
80 syswrite(BIG, "big") or
81     die "syswrite $big1 failed: $!";
82 close(BIG) or
83     die "close $big1 failed: $!";
84
85 my @s1 = stat($big1);
86
87 print "# s1 = @s1\n";
88
89 sysopen(BIG, $big2, O_WRONLY|O_CREAT|O_TRUNC) or
90     die "sysopen $big2 failed: $!";
91 sysseek(BIG, 2_000_000, SEEK_SET) or
92     die "sysseek $big2 failed: $!";
93 syswrite(BIG, "big") or
94     die "syswrite $big2 failed: $!";
95 close(BIG) or
96     die "close $big2 failed: $!";
97
98 my @s2 = stat($big2);
99
100 print "# s2 = @s2\n";
101
102 unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
103         $s1[11] == $s2[11] && $s1[12] == $s2[12] &&
104         $s1[12] > 0) {
105         print "1..0 # Skip: no sparse files?\n";
106         exit 0;
107 }
108
109 print "# we seem to have sparse files...\n";
110
111 # By now we better be sure that we do have sparse files:
112 # if we are not, the following will hog 5 gigabytes of disk.  Ooops.
113 # This may fail by producing some signal; run in a subprocess first for safety
114
115 $ENV{LC_ALL} = "C";
116
117 my $perl = '../../perl';
118 unless (-x $perl) {
119     print "1..1\nnot ok 1 - can't find perl: expected $perl\n";
120     exit 0;
121 }
122 my $r = system $perl, '-I../lib', '-e', <<"EOF";
123 use Fcntl qw(/^O_/ /^SEEK_/);
124 sysopen \$big, q{$big0}, O_WRONLY|O_CREAT|O_TRUNC or die qq{sysopen $big0 $!};
125 sysseek \$big, 5_000_000_000, SEEK_SET or die qq{sysseek $big0 $!};
126 syswrite \$big, "big" or die qq{syswrite $big0 $!};
127 close \$big or die qq{close $big0: $!};
128 exit 0;
129 EOF
130
131
132 sysopen(BIG, $big0, O_WRONLY|O_CREAT|O_TRUNC) or
133     die "sysopen $big0 failed: $!";
134 my $sysseek = sysseek(BIG, 5_000_000_000, SEEK_SET);
135 unless (! $r && defined $sysseek && $sysseek == 5_000_000_000) {
136     $sysseek = 'undef' unless defined $sysseek;
137     explain("seeking past 2GB failed: ",
138             $r ? 'signal '.($r & 0x7f) : "$! (sysseek returned $sysseek)");
139 }
140
141 # The syswrite will fail if there are are filesize limitations (process or fs).
142 my $syswrite = syswrite(BIG, "big");
143 print "# syswrite failed: $! (syswrite returned ",
144       defined $syswrite ? $syswrite : 'undef', ")\n"
145     unless defined $syswrite && $syswrite == 3;
146 my $close     = close BIG;
147 print "# close failed: $!\n" unless $close;
148 unless($syswrite && $close) {
149     if ($! =~/too large/i) {
150         explain("writing past 2GB failed: process limits?");
151     } elsif ($! =~ /quota/i) {
152         explain("filesystem quota limits?");
153     } else {
154         explain("error: $!");
155     }
156 }
157
158 @s = stat($big0);
159
160 print "# @s\n";
161
162 unless ($s[7] == 5_000_000_003) {
163     explain("kernel/fs not configured to use large files?");
164 }
165
166 sub fail {
167     print "not ";
168     $fail++;
169 }
170
171 sub offset ($$) {
172     my ($offset_will_be, $offset_want) = @_;
173     my $offset_is = eval $offset_will_be;
174     unless ($offset_is == $offset_want) {
175         print "# bad offset $offset_is, want $offset_want\n";
176         my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
177         if (unpack("L", pack("L", $offset_want)) == $offset_is) {
178             print "# 32-bit wraparound suspected in $offset_func() since\n";
179             print "# $offset_want cast into 32 bits equals $offset_is.\n";
180         } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
181                  == $offset_is) {
182             print "# 32-bit wraparound suspected in $offset_func() since\n";
183             printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
184                 $offset_want,
185                 $offset_want,
186                 $offset_is;
187         }
188         fail;
189     }
190 }
191
192 print "1..17\n";
193
194 $fail = 0;
195
196 fail unless $s[7] == 5_000_000_003;     # exercizes pp_stat
197 print "ok 1\n";
198
199 fail unless -s $big0 == 5_000_000_003;  # exercizes pp_ftsize
200 print "ok 2\n";
201
202 fail unless -e $big0;
203 print "ok 3\n";
204
205 fail unless -f $big0;
206 print "ok 4\n";
207
208 sysopen(BIG, $big0, O_RDONLY) or die "sysopen failed: $!";
209
210 offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
211 print "ok 5\n";
212
213 offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
214 print "ok 6\n";
215
216 # If you get 205_032_705 from here it means that
217 # your tell() is returning 32-bit values since (I32)4_500_000_001
218 # is exactly 205_032_705.
219 offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001);
220 print "ok 7\n";
221
222 offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001);
223 print "ok 8\n";
224
225 offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000);
226 print "ok 9\n";
227
228 offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
229 print "ok 10\n";
230
231 offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000);
232 print "ok 11\n";
233
234 offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000);
235 print "ok 12\n";
236
237 my $big;
238
239 fail unless sysread(BIG, $big, 3) == 3;
240 print "ok 13\n";
241
242 fail unless $big eq "big";
243 print "ok 14\n";
244
245 # 705_032_704 = (I32)5_000_000_000
246 # See that we don't have "big" in the 705_... spot:
247 # that would mean that we have a wraparound.
248 fail unless sysseek(BIG, 705_032_704, SEEK_SET);
249 print "ok 15\n";
250
251 my $zero;
252
253 fail unless read(BIG, $zero, 3) == 3;
254 print "ok 16\n";
255
256 fail unless $zero eq "\0\0\0";
257 print "ok 17\n";
258
259 explain() if $fail;
260
261 END {
262     # unlink may fail if applied directly to a large file
263     # be paranoid about leaving 5 gig files lying around
264     open(BIG, ">$big0"); # truncate
265     close(BIG);
266 }
267
268 # eof