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