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