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