home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / lfs.t < prev    next >
Text File  |  2000-03-02  |  5KB  |  227 lines
  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.     chdir 't' if -d 't';
  7.     unshift @INC, '../lib';
  8.     # Don't bother if there are no quad offsets.
  9.     require Config; import Config;
  10.     if ($Config{lseeksize} < 8) {
  11.         print "1..0\n# no 64-bit file offsets\n";
  12.         exit(0);
  13.     }
  14. }
  15.  
  16. sub zap {
  17.     close(BIG);
  18.     unlink("big");
  19.     unlink("big1");
  20.     unlink("big2");
  21. }
  22.  
  23. sub bye {
  24.     zap();    
  25.     exit(0);
  26. }
  27.  
  28. sub explain {
  29.     print <<EOM;
  30. #
  31. # If the lfs (large file support: large meaning larger than two gigabytes)
  32. # tests are skipped or fail, it may mean either that your process
  33. # (or process group) is not allowed to write large files (resource
  34. # limits) or that the file system you are running the tests on doesn't
  35. # let your user/group have large files (quota) or the filesystem simply
  36. # doesn't support large files.  You may even need to reconfigure your kernel.
  37. # (This is all very operating system and site-dependent.)
  38. #
  39. # Perl may still be able to support large files, once you have
  40. # such a process, enough quota, and such a (file) system.
  41. #
  42. EOM
  43. }
  44.  
  45. print "# checking whether we have sparse files...\n";
  46.  
  47. # Known have-nots.
  48. if ($^O eq 'win32' || $^O eq 'vms') {
  49.     print "1..0\n# no sparse files (because this is $^O) \n";
  50.     bye();
  51. }
  52.  
  53. # Known haves that have problems running this test
  54. # (for example because they do not support sparse files, like UNICOS)
  55. if ($^O eq 'unicos') {
  56.     print "1..0\n# large files known to work but unable to test them here ($^O)\n";
  57.     bye();
  58. }
  59.  
  60. # Then try to heuristically deduce whether we have sparse files.
  61.  
  62. # Let's not depend on Fcntl or any other extension.
  63.  
  64. my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2);
  65.  
  66. # We'll start off by creating a one megabyte file which has
  67. # only three "true" bytes.  If we have sparseness, we should
  68. # consume less blocks than one megabyte (assuming nobody has
  69. # one megabyte blocks...)
  70.  
  71. open(BIG, ">big1") or
  72.     do { warn "open big1 failed: $!\n"; bye };
  73. binmode(BIG) or
  74.     do { warn "binmode big1 failed: $!\n"; bye };
  75. seek(BIG, 1_000_000, $SEEK_SET) or
  76.     do { warn "seek big1 failed: $!\n"; bye };
  77. print BIG "big" or
  78.     do { warn "print big1 failed: $!\n"; bye };
  79. close(BIG) or
  80.     do { warn "close big1 failed: $!\n"; bye };
  81.  
  82. my @s1 = stat("big1");
  83.  
  84. print "# s1 = @s1\n";
  85.  
  86. open(BIG, ">big2") or
  87.     do { warn "open big2 failed: $!\n"; bye };
  88. binmode(BIG) or
  89.     do { warn "binmode big2 failed: $!\n"; bye };
  90. seek(BIG, 2_000_000, $SEEK_SET) or
  91.     do { warn "seek big2 failed; $!\n"; bye };
  92. print BIG "big" or
  93.     do { warn "print big2 failed; $!\n"; bye };
  94. close(BIG) or
  95.     do { warn "close big2 failed; $!\n"; bye };
  96.  
  97. my @s2 = stat("big2");
  98.  
  99. print "# s2 = @s2\n";
  100.  
  101. zap();
  102.  
  103. unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
  104.     $s1[11] == $s2[11] && $s1[12] == $s2[12]) {
  105.     print "1..0\n#no sparse files?\n";
  106.     bye;
  107. }
  108.  
  109. print "# we seem to have sparse files...\n";
  110.  
  111. # By now we better be sure that we do have sparse files:
  112. # if we are not, the following will hog 5 gigabytes of disk.  Ooops.
  113.  
  114. $ENV{LC_ALL} = "C";
  115.  
  116. open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
  117. binmode BIG;
  118. unless (seek(BIG, 5_000_000_000, $SEEK_SET)) {
  119.     print "1..0\n# seeking past 2GB failed: $!\n";
  120.     explain();
  121.     bye();
  122. }
  123.  
  124. # Either the print or (more likely, thanks to buffering) the close will
  125. # fail if there are are filesize limitations (process or fs).
  126. my $print = print BIG "big";
  127. print "# print failed: $!\n" unless $print;
  128. my $close = close BIG;
  129. print "# close failed: $!\n" unless $close;
  130. unless ($print && $close) {
  131.     if ($! =~/too large/i) {
  132.     print "1..0\n# writing past 2GB failed: process limits?\n";
  133.     } elsif ($! =~ /quota/i) {
  134.     print "1..0\n# filesystem quota limits?\n";
  135.     }
  136.     explain();
  137.     bye();
  138. }
  139.  
  140. @s = stat("big");
  141.  
  142. print "# @s\n";
  143.  
  144. unless ($s[7] == 5_000_000_003) {
  145.     print "1..0\n# not configured to use large files?\n";
  146.     explain();
  147.     bye();
  148. }
  149.  
  150. sub fail () {
  151.     print "not ";
  152.     $fail++;
  153. }
  154.  
  155. print "1..17\n";
  156.  
  157. my $fail = 0;
  158.  
  159. fail unless $s[7] == 5_000_000_003;    # exercizes pp_stat
  160. print "ok 1\n";
  161.  
  162. fail unless -s "big" == 5_000_000_003;    # exercizes pp_ftsize
  163. print "ok 2\n";
  164.  
  165. fail unless -e "big";
  166. print "ok 3\n";
  167.  
  168. fail unless -f "big";
  169. print "ok 4\n";
  170.  
  171. open(BIG, "big") or do { warn "open failed: $!\n"; bye };
  172. binmode BIG;
  173.  
  174. fail unless seek(BIG, 4_500_000_000, $SEEK_SET);
  175. print "ok 5\n";
  176.  
  177. fail unless tell(BIG) == 4_500_000_000;
  178. print "ok 6\n";
  179.  
  180. fail unless seek(BIG, 1, $SEEK_CUR);
  181. print "ok 7\n";
  182.  
  183. fail unless tell(BIG) == 4_500_000_001;
  184. print "ok 8\n";
  185.  
  186. fail unless seek(BIG, -1, $SEEK_CUR);
  187. print "ok 9\n";
  188.  
  189. fail unless tell(BIG) == 4_500_000_000;
  190. print "ok 10\n";
  191.  
  192. fail unless seek(BIG, -3, $SEEK_END);
  193. print "ok 11\n";
  194.  
  195. fail unless tell(BIG) == 5_000_000_000;
  196. print "ok 12\n";
  197.  
  198. my $big;
  199.  
  200. fail unless read(BIG, $big, 3) == 3;
  201. print "ok 13\n";
  202.  
  203. fail unless $big eq "big";
  204. print "ok 14\n";
  205.  
  206. # 705_032_704 = (I32)5_000_000_000
  207. fail unless seek(BIG, 705_032_704, $SEEK_SET);
  208. print "ok 15\n";
  209.  
  210. my $zero;
  211.  
  212. fail unless read(BIG, $zero, 3) == 3;
  213. print "ok 16\n";
  214.  
  215. fail unless $zero eq "\0\0\0";
  216. print "ok 17\n";
  217.  
  218. explain if $fail;
  219.  
  220. bye(); # does the necessary cleanup
  221.  
  222. END {
  223.    unlink "big"; # be paranoid about leaving 5 gig files lying around
  224. }
  225.  
  226. # eof
  227.