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                 exit(0);
  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                 exit(0);
  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 my $BLOCKSIZE = 512; # is this really correct everywhere?
  58
  59 unless (@s == 13 &&
  60         $s[7] == 1_000_003 &&
  61         defined $s[12] &&
  62         $BLOCKSIZE * $s[12] < 1_000_003) {
  63     print "1..0\n# no sparse files?\n";
  64     bye();
  65 }
  66
  67 # By now we better be sure that we do have sparse files:
  68 # if we are not, the following will hog 5 gigabytes of disk.  Ooops.
  69
  70 print "1..8\n";
  71
  72 my $fail = 0;
  73
  74 open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
  75 binmode BIG;
  76 seek(BIG, 5_000_000_000, $SEEK_SET);
  77 print BIG "big";
  78 close BIG;
  79
  80 @s = stat("big");
  81
  82 print "# @s\n";
  83
  84 sub fail () {
  85     print "not ";
  86     $fail++;
  87 }
  88
  89 fail unless $s[7] == 5_000_000_003;     # exercizes pp_stat
  90 print "ok 1\n";
  91
  92 fail unless -s "big" == 5_000_000_003;  # exercizes pp_ftsize
  93 print "ok 2\n";
  94
  95 open(BIG, "big") or do { warn "open failed: $!\n"; bye };
  96 binmode BIG;
  97
  98 seek(BIG, 4_500_000_000, $SEEK_SET);
  99
 100 fail unless tell(BIG) == 4_500_000_000;
 101 print "ok 3\n";
 102
 103 seek(BIG, 1, $SEEK_CUR);
 104
 105 fail unless tell(BIG) == 4_500_000_001;
 106 print "ok 4\n";
 107
 108 seek(BIG, -1, $SEEK_CUR);
 109
 110 fail unless tell(BIG) == 4_500_000_000;
 111 print "ok 5\n";
 112
 113 seek(BIG, -3, $SEEK_END);
 114
 115 fail unless tell(BIG) == 5_000_000_000;
 116 print "ok 6\n";
 117
 118 my $big;
 119
 120 fail unless read(BIG, $big, 3) == 3;
 121 print "ok 7\n";
 122
 123 fail unless $big eq "big";
 124 print "ok 8\n";
 125
 126 if ($fail) {
 127     print STDERR <<EOM;
 128 #
 129 # If the lfs (large file support) tests fail, it may mean that
 130 # the *file system* you are running the tests on doesn't support
 131 # large files (files larger than two gigabytes).  Perl may still
 132 # be able to support such files, once you have such a file system.
 133 #
 134 EOM
 135 }
 136
 137 bye();
 138
 139 # eof