cpan/Tie-File/t/25_gen_nocache.t

   1 #!/usr/bin/perl
   2 #
   3 # Regular read-write tests with caching disabled
   4 # (Same as 01_gen.t)
   5 #
   6 my $file = "tf$$.txt";
   7
   8 print "1..68\n";
   9
  10 my $N = 1;
  11 use Tie::File;
  12 print "ok $N\n"; $N++;
  13
  14 my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0, memory => 0;
  15 print $o ? "ok $N\n" : "not ok $N\n";
  16 $N++;
  17
  18 $: = $o->{recsep};
  19
  20 # 3-5 create
  21 $a[0] = 'rec0';
  22 check_contents("rec0");
  23
  24 # 6-11 append
  25 $a[1] = 'rec1';
  26 check_contents("rec0", "rec1");
  27 $a[2] = 'rec2';
  28 check_contents("rec0", "rec1", "rec2");
  29
  30 # 12-20 same-length alterations
  31 $a[0] = 'new0';
  32 check_contents("new0", "rec1", "rec2");
  33 $a[1] = 'new1';
  34 check_contents("new0", "new1", "rec2");
  35 $a[2] = 'new2';
  36 check_contents("new0", "new1", "new2");
  37
  38 # 21-35 lengthening alterations
  39 $a[0] = 'long0';
  40 check_contents("long0", "new1", "new2");
  41 $a[1] = 'long1';
  42 check_contents("long0", "long1", "new2");
  43 $a[2] = 'long2';
  44 check_contents("long0", "long1", "long2");
  45 $a[1] = 'longer1';
  46 check_contents("long0", "longer1", "long2");
  47 $a[0] = 'longer0';
  48 check_contents("longer0", "longer1", "long2");
  49
  50 # 36-50 shortening alterations, including truncation
  51 $a[0] = 'short0';
  52 check_contents("short0", "longer1", "long2");
  53 $a[1] = 'short1';
  54 check_contents("short0", "short1", "long2");
  55 $a[2] = 'short2';
  56 check_contents("short0", "short1", "short2");
  57 $a[1] = 'sh1';
  58 check_contents("short0", "sh1", "short2");
  59 $a[0] = 'sh0';
  60 check_contents("sh0", "sh1", "short2");
  61
  62 # (51-56) file with holes
  63 $a[4] = 'rec4';
  64 check_contents("sh0", "sh1", "short2", "", "rec4");
  65 $a[3] = 'rec3';
  66 check_contents("sh0", "sh1", "short2", "rec3", "rec4");
  67
  68 # (57-59) zero out file
  69 @a = ();
  70 check_contents();
  71
  72 # (60-62) insert into the middle of an empty file
  73 $a[3] = "rec3";
  74 check_contents("", "", "", "rec3");
  75
  76 # (63-68) 20020326 You thought there would be a bug in STORE where if
  77 # a cached record was false, STORE wouldn't see it at all.  But you
  78 # forgot that records always come back from the cache with the record
  79 # separator attached, so they are unlikely to be false.  The only
  80 # really weird case is when the cached record is empty and the record
  81 # separator is "0".  Test that in 09_gen_rs.t.
  82 $a[1] = "0";
  83 check_contents("", "0", "", "rec3");
  84 $a[1] = "whoops";
  85 check_contents("", "whoops", "", "rec3");
  86
  87
  88 use POSIX 'SEEK_SET';
  89 sub check_contents {
  90   my @c = @_;
  91   my $x = join $:, @c, '';
  92   local *FH = $o->{fh};
  93   seek FH, 0, SEEK_SET;
  94 #  my $open = open FH, "< $file";
  95   my $a;
  96   { local $/; $a = <FH> }
  97   $a = "" unless defined $a;
  98   if ($a eq $x) {
  99     print "ok $N\n";
 100   } else {
 101     ctrlfix($a, $x);
 102     print "not ok $N\n# expected <$x>, got <$a>\n";
 103   }
 104   $N++;
 105
 106   # now check FETCH:
 107   my $good = 1;
 108   my $msg;
 109   for (0.. $#c) {
 110     my $aa = $a[$_];
 111     unless ($aa eq "$c[$_]$:") {
 112       $msg = "expected <$c[$_]$:>, got <$aa>";
 113       ctrlfix($msg);
 114       $good = 0;
 115     }
 116   }
 117   print $good ? "ok $N\n" : "not ok $N # $msg\n";
 118   $N++;
 119
 120   print $o->_check_integrity($file, $ENV{INTEGRITY})
 121       ? "ok $N\n" : "not ok $N\n";
 122   $N++;
 123 }
 124
 125 sub ctrlfix {
 126   for (@_) {
 127     s/\n/\\n/g;
 128     s/\r/\\r/g;
 129   }
 130 }
 131
 132 END {
 133   undef $o;
 134   untie @a;
 135   1 while unlink $file;
 136 }
 137