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         # Don't bother if there are no quads.
   7         eval { my $q = pack "q", 0 };
   8         if ($@) {
   9                 print "1..0\n# no 64-bit types\n";
  10                 bye();
  11         }
  12         chdir 't' if -d 't';
  13         unshift @INC, '../lib';
  14 }
  15
  16 sub bye {
  17     close(BIG);
  18     unlink "big";
  19     exit(0);
  20 }
  21
  22 # Known have-nots.
  23 if ($^O eq 'win32' || $^O eq 'vms') {
  24     print "1..0\n# no sparse files\n";
  25     bye();
  26 }
  27
  28 # Then try to deduce whether we have sparse files.
  29
  30 my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2);
  31
  32 # We'll start off by creating a one megabyte file which has
  33 # only three "true" bytes.  If we have sparseness, we should
  34 # consume less blocks than one megabyte (assuming nobody has
  35 # one megabyte blocks...)
  36
  37 open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
  38 binmode BIG;
  39 seek(BIG, 1_000_000, $SEEK_SET);
  40 print BIG "big";
  41 close(BIG);
  42
  43 my @s;
  44
  45 @s = stat("big");
  46
  47 print "# @s\n";
  48
  49 unless (@s == 13 &&
  50         $s[7] == 1_000_003 &&
  51         defined $s[11] &&
  52         defined $s[12] &&
  53        $s[11] * $s[12] < 1000_003) {
  54     print "1..0\n# no sparse files?\n";
  55     bye();
  56 }
  57
  58 # By now we better be sure that we do have sparse files:
  59 # if we are not, the following will hog 5 gigabytes of disk.  Ooops.
  60
  61 print "1..8\n";
  62
  63 my $fail = 0;
  64
  65 open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
  66 binmode BIG;
  67 seek(BIG, 5_000_000_000, $SEEK_SET);
  68 print BIG "big";
  69 close BIG;
  70
  71 @s = stat("big");
  72
  73 print "# @s\n";
  74
  75 sub fail () {
  76     print " not ";
  77     $fail++;
  78 }
  79
  80 fail unless $s[7] == 5_000_000_003;
  81 print "ok 1\n";
  82
  83 fail unless -s "big" == 5_000_000_003;
  84 print "ok 2\n";
  85
  86 open(BIG, "big") or do { warn "open failed: $!\n"; bye };
  87 binmode BIG;
  88
  89 seek(BIG, 4_500_000_000, $SEEK_SET);
  90
  91 fail unless tell(BIG) == 4_500_000_000;
  92 print "ok 3\n";
  93
  94 seek(BIG, 1, $SEEK_CUR);
  95
  96 fail unless tell(BIG) == 4_500_000_001;
  97 print "ok 4\n";
  98
  99 seek(BIG, -1, $SEEK_CUR);
 100
 101 fail unless tell(BIG) == 4_500_000_000;
 102 print "ok 5\n";
 103
 104 seek(BIG, -3, $SEEK_END);
 105
 106 fail unless tell(BIG) == 5_000_000_000;
 107 print "ok 6\n";
 108
 109 my $big;
 110
 111 fail unless read(BIG, $big, 3) == 3;
 112 print "ok 7\n";
 113
 114 fail unless $big eq "big";
 115 print "ok 8\n";
 116
 117 bye();
 118
 119 if ($fail) {
 120     print STDERR <<EOM;
 121 #
 122 # If the lfs (large file support) tests fail, it means that
 123 # the *file system* you are running the tests on doesn't support
 124 # large files (files larger than two gigabytes).  Perl may still
 125 # be able to support such files, once you have such a file system.
 126 #
 127 EOM
 128 }
 129
 130 # eof