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