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