1#!/usr/bin/perl
2#
3# Regular read-write tests with caching disabled
4# (Same as 01_gen.t)
5#
6my $file = "tf$$.txt";
7
8print "1..68\n";
9
10my $N = 1;
11use Tie::File;
12print "ok $N\n"; $N++;
13
14my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0, memory => 0;
15print $o ? "ok $N\n" : "not ok $N\n";
16$N++;
17
18$: = $o->{recsep};
19
20# 3-5 create
21$a[0] = 'rec0';
22check_contents("rec0");
23
24# 6-11 append
25$a[1] = 'rec1';
26check_contents("rec0", "rec1");
27$a[2] = 'rec2';
28check_contents("rec0", "rec1", "rec2");
29
30# 12-20 same-length alterations
31$a[0] = 'new0';
32check_contents("new0", "rec1", "rec2");
33$a[1] = 'new1';
34check_contents("new0", "new1", "rec2");
35$a[2] = 'new2';
36check_contents("new0", "new1", "new2");
37
38# 21-35 lengthening alterations
39$a[0] = 'long0';
40check_contents("long0", "new1", "new2");
41$a[1] = 'long1';
42check_contents("long0", "long1", "new2");
43$a[2] = 'long2';
44check_contents("long0", "long1", "long2");
45$a[1] = 'longer1';
46check_contents("long0", "longer1", "long2");
47$a[0] = 'longer0';
48check_contents("longer0", "longer1", "long2");
49
50# 36-50 shortening alterations, including truncation
51$a[0] = 'short0';
52check_contents("short0", "longer1", "long2");
53$a[1] = 'short1';
54check_contents("short0", "short1", "long2");
55$a[2] = 'short2';
56check_contents("short0", "short1", "short2");
57$a[1] = 'sh1';
58check_contents("short0", "sh1", "short2");
59$a[0] = 'sh0';
60check_contents("sh0", "sh1", "short2");
61
62# (51-56) file with holes
63$a[4] = 'rec4';
64check_contents("sh0", "sh1", "short2", "", "rec4");
65$a[3] = 'rec3';
66check_contents("sh0", "sh1", "short2", "rec3", "rec4");
67
68# (57-59) zero out file
69@a = ();
70check_contents();
71
72# (60-62) insert into the middle of an empty file
73$a[3] = "rec3";
74check_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";
83check_contents("", "0", "", "rec3");
84$a[1] = "whoops";
85check_contents("", "whoops", "", "rec3");
86
87
88use POSIX 'SEEK_SET';
89sub 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
125sub ctrlfix {
126  for (@_) {
127    s/\n/\\n/g;
128    s/\r/\\r/g;
129  }
130}
131
132END {
133  undef $o;
134  untie @a;
135  1 while unlink $file;
136}
137
138