t/lib/syslfs.t

   1 # NOTE: this file tests how large files (>2GB) work with raw system IO.
   2 # open(), tell(), seek(), print(), read() are tested in t/op/lfs.t.
   3 # If you modify/add tests here, remember to update also t/op/lfs.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         require Config; import Config;
  15         # Don't bother if there are no quad offsets.
  16         if ($Config{lseeksize} < 8) {
  17                 print "1..0\n# no 64-bit file offsets\n";
  18                 exit(0);
  19         }
  20         require Fcntl; import Fcntl;
  21 }
  22
  23 sub bye {
  24     close(BIG);
  25     unlink "big";
  26     exit(0);
  27 }
  28
  29 sub explain {
  30     print STDERR <<EOM;
  31 #
  32 # If the lfs (large file support: large meaning larger than two gigabytes)
  33 # tests fail, it may mean either that your process is not allowed to write
  34 # large files or that the file system you are running the tests on doesn't
  35 # support large files, or both.
  36 #
  37 # Perl may still be able to support large files, once you have
  38 # such a process and such a file system.
  39 #
  40 EOM
  41 }
  42
  43 # Known have-nots.
  44 if ($^O eq 'win32' || $^O eq 'vms') {
  45     print "1..0\n# no sparse files\n";
  46     bye();
  47 }
  48
  49 # Then try to deduce whether we have sparse files.
  50
  51 # We'll start off by creating a one megabyte file which has
  52 # only three "true" bytes.  If we have sparseness, we should
  53 # consume less blocks than one megabyte (assuming nobody has
  54 # one megabyte blocks...)
  55
  56 sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or
  57         do { warn "sysopen failed: $!\n"; bye };
  58 sysseek(BIG, 1_000_000, SEEK_SET);
  59 syswrite(BIG, "big");
  60 close(BIG);
  61
  62 my @s;
  63
  64 @s = stat("big");
  65
  66 print "# @s\n";
  67
  68 my $BLOCKSIZE = 512; # is this really correct everywhere?
  69
  70 unless (@s == 13 &&
  71         $s[7] == 1_000_003 &&
  72         defined $s[12] &&
  73         $BLOCKSIZE * $s[12] < 1_000_003) {
  74     print "1..0\n# no sparse files?\n";
  75     bye();
  76 }
  77
  78 # By now we better be sure that we do have sparse files:
  79 # if we are not, the following will hog 5 gigabytes of disk.  Ooops.
  80
  81 sysopen(BIG, "big", O_WRONLY|O_CREAT|O_TRUNC) or
  82         do { warn "sysopen failed: $!\n"; bye };
  83 sysseek(BIG, 5_000_000_000, SEEK_SET);
  84 # The syswrite will fail if there are are filesize limitations (process or fs).
  85 unless(syswrite(BIG, "big") == 3) {
  86     $ENV{LC_ALL} = "C";
  87     if ($! =~/File too large/) {
  88         print "1..0\n# writing past 2GB failed\n";
  89         explain();
  90         bye();
  91     }
  92 }
  93 close BIG;
  94
  95 @s = stat("big");
  96
  97 print "# @s\n";
  98
  99 sub fail () {
 100     print "not ";
 101     $fail++;
 102 }
 103
 104 print "1..8\n";
 105
 106 my $fail = 0;
 107
 108 fail unless $s[7] == 5_000_000_003;     # exercizes pp_stat
 109 print "ok 1\n";
 110
 111 fail unless -s "big" == 5_000_000_003;  # exercizes pp_ftsize
 112 print "ok 2\n";
 113
 114 sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };
 115
 116 sysseek(BIG, 4_500_000_000, SEEK_SET);
 117
 118 fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
 119 print "ok 3\n";
 120
 121 sysseek(BIG, 1, SEEK_CUR);
 122
 123 fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001;
 124 print "ok 4\n";
 125
 126 sysseek(BIG, -1, SEEK_CUR);
 127
 128 fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
 129 print "ok 5\n";
 130
 131 sysseek(BIG, -3, SEEK_END);
 132
 133 fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000;
 134 print "ok 6\n";
 135
 136 my $big;
 137
 138 fail unless sysread(BIG, $big, 3) == 3;
 139 print "ok 7\n";
 140
 141 fail unless $big eq "big";
 142 print "ok 8\n";
 143
 144 explain if $fail;
 145
 146 bye();
 147
 148 # eof