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