| 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 | } |
| 15 | |
| 16 | use strict; |
| 17 | |
| 18 | our @s; |
| 19 | our $fail; |
| 20 | |
| 21 | sub zap { |
| 22 | close(BIG); |
| 23 | unlink("big"); |
| 24 | unlink("big1"); |
| 25 | unlink("big2"); |
| 26 | } |
| 27 | |
| 28 | sub bye { |
| 29 | zap(); |
| 30 | exit(0); |
| 31 | } |
| 32 | |
| 33 | my $explained; |
| 34 | |
| 35 | sub 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 | # |
| 52 | EOM |
| 53 | } |
| 54 | print "1..0 # Skip: @_\n" if @_; |
| 55 | } |
| 56 | |
| 57 | $| = 1; |
| 58 | |
| 59 | print "# checking whether we have sparse files...\n"; |
| 60 | |
| 61 | # Known have-nots. |
| 62 | if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { |
| 63 | print "1..0 # Skip: no sparse files in $^O\n"; |
| 64 | bye(); |
| 65 | } |
| 66 | |
| 67 | # Known haves that have problems running this test |
| 68 | # (for example because they do not support sparse files, like UNICOS) |
| 69 | if ($^O eq 'unicos') { |
| 70 | print "1..0 # Skip: no sparse files in $^O, unable to test large files\n"; |
| 71 | bye(); |
| 72 | } |
| 73 | |
| 74 | # Then try to heuristically deduce whether we have sparse files. |
| 75 | |
| 76 | # Let's not depend on Fcntl or any other extension. |
| 77 | |
| 78 | my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); |
| 79 | |
| 80 | # We'll start off by creating a one megabyte file which has |
| 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...) |
| 84 | |
| 85 | open(BIG, ">big1") or |
| 86 | do { warn "open big1 failed: $!\n"; bye }; |
| 87 | binmode(BIG) or |
| 88 | do { warn "binmode big1 failed: $!\n"; bye }; |
| 89 | seek(BIG, 1_000_000, $SEEK_SET) or |
| 90 | do { warn "seek big1 failed: $!\n"; bye }; |
| 91 | print BIG "big" or |
| 92 | do { warn "print big1 failed: $!\n"; bye }; |
| 93 | close(BIG) or |
| 94 | do { warn "close big1 failed: $!\n"; bye }; |
| 95 | |
| 96 | my @s1 = stat("big1"); |
| 97 | |
| 98 | print "# s1 = @s1\n"; |
| 99 | |
| 100 | open(BIG, ">big2") or |
| 101 | do { warn "open big2 failed: $!\n"; bye }; |
| 102 | binmode(BIG) or |
| 103 | do { warn "binmode big2 failed: $!\n"; bye }; |
| 104 | seek(BIG, 2_000_000, $SEEK_SET) or |
| 105 | do { warn "seek big2 failed; $!\n"; bye }; |
| 106 | print BIG "big" or |
| 107 | do { warn "print big2 failed; $!\n"; bye }; |
| 108 | close(BIG) or |
| 109 | do { warn "close big2 failed; $!\n"; bye }; |
| 110 | |
| 111 | my @s2 = stat("big2"); |
| 112 | |
| 113 | print "# s2 = @s2\n"; |
| 114 | |
| 115 | zap(); |
| 116 | |
| 117 | unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && |
| 118 | $s1[11] == $s2[11] && $s1[12] == $s2[12]) { |
| 119 | print "1..0 # Skip: no sparse files?\n"; |
| 120 | bye; |
| 121 | } |
| 122 | |
| 123 | print "# we seem to have sparse files...\n"; |
| 124 | |
| 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. |
| 127 | # This may fail by producing some signal; run in a subprocess first for safety |
| 128 | |
| 129 | $ENV{LC_ALL} = "C"; |
| 130 | |
| 131 | my $r = system '../perl', '-e', <<'EOF'; |
| 132 | open(BIG, ">big"); |
| 133 | seek(BIG, 5_000_000_000, 0); |
| 134 | print BIG "big"; |
| 135 | exit 0; |
| 136 | EOF |
| 137 | |
| 138 | open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; |
| 139 | binmode BIG; |
| 140 | if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { |
| 141 | my $err = $r ? 'signal '.($r & 0x7f) : $!; |
| 142 | explain("seeking past 2GB failed: $err"); |
| 143 | bye(); |
| 144 | } |
| 145 | |
| 146 | # Either the print or (more likely, thanks to buffering) the close will |
| 147 | # fail if there are are filesize limitations (process or fs). |
| 148 | my $print = print BIG "big"; |
| 149 | print "# print failed: $!\n" unless $print; |
| 150 | my $close = close BIG; |
| 151 | print "# close failed: $!\n" unless $close; |
| 152 | unless ($print && $close) { |
| 153 | if ($! =~/too large/i) { |
| 154 | explain("writing past 2GB failed: process limits?"); |
| 155 | } elsif ($! =~ /quota/i) { |
| 156 | explain("filesystem quota limits?"); |
| 157 | } else { |
| 158 | explain("error: $!"); |
| 159 | } |
| 160 | bye(); |
| 161 | } |
| 162 | |
| 163 | @s = stat("big"); |
| 164 | |
| 165 | print "# @s\n"; |
| 166 | |
| 167 | unless ($s[7] == 5_000_000_003) { |
| 168 | explain("kernel/fs not configured to use large files?"); |
| 169 | bye(); |
| 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 "big" == 5_000_000_003; # exercizes pp_ftsize |
| 206 | print "ok 2\n"; |
| 207 | |
| 208 | fail unless -e "big"; |
| 209 | print "ok 3\n"; |
| 210 | |
| 211 | fail unless -f "big"; |
| 212 | print "ok 4\n"; |
| 213 | |
| 214 | open(BIG, "big") 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, ">big"); # truncate |
| 274 | close(BIG); |
| 275 | 1 while unlink "big"; # standard portable idiom |
| 276 | } |
| 277 | |
| 278 | # eof |