1#!/usr/bin/perl
2#
3# Check interactions of deferred writing
4# with miscellaneous methods like DELETE, EXISTS,
5# FETCHSIZE, STORESIZE, CLEAR, EXTEND
6#
7
8use POSIX 'SEEK_SET';
9my $file = "tf$$.txt";
10$: = Tie::File::_default_recsep();
11my $data = "rec0$:rec1$:rec2$:";
12my ($o, $n);
13
14print "1..53\n";
15
16my $N = 1;
17use Tie::File;
18print "ok $N\n"; $N++;
19
20open F, "> $file" or die $!;
21binmode F;
22print F $data;
23close F;
24$o = tie @a, 'Tie::File', $file;
25print $o ? "ok $N\n" : "not ok $N\n";
26$N++;
27
28# (3-6) EXISTS
29if ($] >= 5.006) {
30  eval << 'TESTS';
31$o->defer;
32expect(not exists $a[4]);
33$a[4] = "rec4";
34expect(exists $a[4]);
35check_contents($data);          # nothing written yet
36$o->discard;
37TESTS
38} else {
39    for (3..6) {
40      print "ok $_ \# skipped (no exists for arrays)\n";
41          $N++;
42    }
43}
44
45# (7-10) FETCHSIZE
46$o->defer;
47expect($#a, 2);
48$a[4] = "rec4";
49expect($#a, 4);
50check_contents($data);          # nothing written yet
51$o->discard;
52
53# (11-21) STORESIZE
54$o->defer;
55$#a = 4;
56check_contents($data);          # nothing written yet
57expect($#a, 4);
58$o->flush;
59expect($#a, 4);
60check_contents("$data$:$:");    # two extra empty records
61
62$o->defer;
63$a[4] = "rec4";
64$#a = 2;
65expect($a[4], undef);
66check_contents($data);          # written data was unwritten
67$o->flush;
68check_contents($data);          # nothing left to write
69
70# (22-28) CLEAR
71$o->defer;
72$a[9] = "rec9";
73check_contents($data);          # nothing written yet
74@a = ();
75check_contents("");             # this happens right away
76expect($a[9], undef);
77$o->flush;
78check_contents("");             # nothing left to write
79
80# (29-34) EXTEND
81# Actually it's not real clear what these tests are for
82# since EXTEND has no defined semantics
83$o->defer;
84@a = (0..3);
85check_contents("");             # nothing happened yet
86expect($a[3], "3");
87expect($a[4], undef);
88$o->flush;
89check_contents("0$:1$:2$:3$:"); # file now 4 records long
90
91# (35-53) DELETE
92if ($] >= 5.006) {
93  eval << 'TESTS';
94my $del;
95$o->defer;
96$del = delete $a[2];
97check_contents("0$:1$:2$:3$:"); # nothing happened yet
98expect($a[2], "");
99expect($del, "2");
100$del = delete $a[3];            # shortens file!
101check_contents("0$:1$:2$:");    # deferred writes NOT flushed
102expect($a[3], undef);
103expect($a[2], "");
104expect($del, "3");
105$a[2] = "cookies";
106$del = delete $a[2];            # shortens file!
107expect($a[2], undef);
108expect($del, 'cookies');
109check_contents("0$:1$:");
110$a[0] = "crackers";
111$del = delete $a[0];            # file unchanged
112expect($a[0], "");
113expect($del, 'crackers');
114check_contents("0$:1$:");       # no change yet
115$o->flush;
116check_contents("$:1$:");        # record 0 is NOT 'cookies';
117TESTS
118} else {
119    for (35..53) {
120      print "ok $_ \# skipped (no delete for arrays)\n";
121          $N++;
122    }
123}
124
125################################################################
126
127
128sub check_caches {
129  my ($xcache, $xdefer) = @_;
130
131#  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
132#  print $integrity ? "ok $N\n" : "not ok $N\n";
133#  $N++;
134
135  my $good = 1;
136  $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
137  $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
138  print $good ? "ok $N\n" : "not ok $N\n";
139  $N++;
140}
141
142sub hash_equal {
143  my ($a, $b, $ha, $hb) = @_;
144  $ha = 'first hash'  unless defined $ha;
145  $hb = 'second hash' unless defined $hb;
146
147  my $good = 1;
148  my %b_seen;
149
150  for my $k (keys %$a) {
151    if (! exists $b->{$k}) {
152      print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
153      $good = 0;
154    } elsif ($b->{$k} ne $a->{$k}) {
155      print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
156      $b_seen{$k} = 1;
157      $good = 0;
158    } else {
159      $b_seen{$k} = 1;
160    }
161  }
162
163  for my $k (keys %$b) {
164    unless ($b_seen{$k}) {
165      print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
166      $good = 0;
167    }
168  }
169
170  $good;
171}
172
173
174sub check_contents {
175  my $x = shift;
176
177  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
178  print $integrity ? "ok $N\n" : "not ok $N\n";
179  $N++;
180
181  local *FH = $o->{fh};
182  seek FH, 0, SEEK_SET;
183
184  my $a;
185  { local $/; $a = <FH> }
186  $a = "" unless defined $a;
187  if ($a eq $x) {
188    print "ok $N\n";
189  } else {
190    my $msg = ctrlfix("# expected <$x>, got <$a>");
191    print "not ok $N\n$msg\n";
192  }
193  $N++;
194}
195
196sub expect {
197  if (@_ == 1) {
198    print $_[0] ? "ok $N\n" : "not ok $N\n";
199  } elsif (@_ == 2) {
200    my ($a, $x) = @_;
201    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
202    elsif (  defined($a) && ! defined($x)) {
203      ctrlfix(my $msg = "expected UNDEF, got <$a>");
204      print "not ok $N \# $msg\n";
205    }
206    elsif (! defined($a) &&   defined($x)) {
207      ctrlfix(my $msg = "expected <$x>, got UNDEF");
208      print "not ok $N \# $msg\n";
209    } elsif ($a eq $x) { print "ok $N\n" }
210    else {
211      ctrlfix(my $msg = "expected <$x>, got <$a>");
212      print "not ok $N \# $msg\n";
213    }
214  } else {
215    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
216  }
217  $N++;
218}
219
220sub ctrlfix {
221  local $_ = shift;
222  s/\n/\\n/g;
223  s/\r/\\r/g;
224  $_;
225}
226
227END {
228  undef $o;
229  untie @a;
230  1 while unlink $file;
231}
232
233