[p5sagit/p5-mst-13.2.git] / lib / Tie / File / t / 30_defer.t

#!/usr/bin/perl
#
# Check ->defer and ->flush methods
#

use POSIX 'SEEK_SET';
my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";
my ($o, $n);

print "1..79\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;
$o = tie @a, 'Tie::File', $file;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (3-6) Deferred storage
$o->defer;
$a[3] = "rec3";
check_contents($data);          # nothing written yet
$a[4] = "rec4";
check_contents($data);          # nothing written yet

# (7-8) Flush
$o->flush;
check_contents($data . "rec3$:rec4$:");          # now it's written

# (9-12) Deferred writing disabled?
$a[3] = "rec9";
check_contents("${data}rec9$:rec4$:");
$a[4] = "rec8";
check_contents("${data}rec9$:rec8$:");

# (13-18) Now let's try two batches of records
$#a = 2;
$o->defer;
$a[0] = "record0";
check_contents($data);          # nothing written yet
$a[2] = "record2";
check_contents($data);          # nothing written yet
$o->flush;
check_contents("record0$:rec1$:record2$:");

# (19-22) Deferred writing past the end of the file
$o->defer;
$a[4] = "record4";
check_contents("record0$:rec1$:record2$:");
$o->flush;
check_contents("record0$:rec1$:record2$:$:record4$:");


# (23-26) Now two long batches
$o->defer;
for (0..2, 4..6) {
  $a[$_] = "r$_";
}
check_contents("record0$:rec1$:record2$:$:record4$:");
$o->flush;
check_contents(join $:, "r0".."r2", "", "r4".."r6", "");

# (27-30) Now let's make sure that discarded writes are really discarded
# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
# filling it up
$o->defer;
for (0, 3, 7) {
  $a[$_] = "discarded$_";
}
check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
$o->discard;
check_contents(join $:, "r0".."r2", "", "r4".."r6", "");

################################################################
#
# Now we're going to test the results of a small memory limit
#
# 
undef $o;  untie @a;
$data = join "$:", map("record$_", 0..7), "";  # records are 8 or 9 bytes long
open F, "> $file" or die $!;
binmode F;
print F $data;
close F;

# Limit cache+buffer size to 47 bytes 
my $MAX = 47;
#  -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
my $BUF = 20;
#  -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (31-32) Fill up the read cache
my @z;
@z = @a;                        
# the cache now contains records 3,4,5,6,7.
check_caches({map(($_ => "record$_$:"), 3..7)}, 
             {});

# (33-44) See if overloading the defer starts by flushing the read cache
# and then flushes out the defer
$o->defer;
$a[0] = "recordA";              # That should flush record 3 from the cache
check_caches({map(($_ => "record$_$:"), 4..7)}, 
             {0 => "recordA$:"});
check_contents($data);

$a[1] = "recordB";              # That should flush record 4 from the cache
check_caches({map(($_ => "record$_$:"), 5..7)}, 
             {0 => "recordA$:",
              1 => "recordB$:"});
check_contents($data);

$a[2] = "recordC";              # That should flush the whole darn defer
# Flushing the defer requires looking up the true lengths of records
# 0..2, which flushes out the read cache, leaving only 1..2 there.
# Then the splicer updates the cached versions of 1..2 to contain the
# new data
check_caches({1 => "recordB$:", 2 => "recordC$:"},
             {});               # URRRP
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

$a[3] = "recordD";         # even though we flushed, deferring is STILL ENABLED
check_caches({1 => "recordB$:", 2 => "recordC$:"},
             {3 => "recordD$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# Check readcache-deferbuffer interactions

# (45-47) This should remove outdated data from the read cache
$a[2] = "recordE";
check_caches({1 => "recordB$:",                 },
             {3 => "recordD$:", 2 => "recordE$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# (48-51) This should read back out of the defer buffer 
# without adding anything to the read cache
my $z;
$z = $a[2];
print $z eq "recordE" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({1 => "recordB$:",                 },
             {3 => "recordD$:", 2 => "recordE$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# (52-55) This should repopulate the read cache with a new record
$z = $a[0];
print $z eq "recordA" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({1 => "recordB$:", 0 => "recordA$:"},
             {3 => "recordD$:", 2 => "recordE$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# (56-59) This should flush the LRU record from the read cache
$z = $a[4];  $z = $a[5];
print $z eq "record5" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({5 => "record5$:", 0 => "recordA$:", 4 => "record4$:"},
             {3 => "recordD$:", 2 => "recordE$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# (60-63) This should FLUSH the deferred buffer
# In doing so, it will read in records 2 and 3, flushing 0 and 4
# from the read cache, leaving 2, 3, and 5.
$z = splice @a, 3, 1, "recordZ";
print $z eq "recordD" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({5 => "record5$:", 3 => "recordZ$:", 2 => "recordE$:"},
             {}); 
check_contents(join("$:", qw(recordA recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");

# (64-66) We should STILL be in deferred writing mode
$a[5] = "recordX";
check_caches({3 => "recordZ$:", 2 => "recordE$:"},
             {5 => "recordX$:"}); 
check_contents(join("$:", qw(recordA recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");

# Fill up the defer buffer again
$a[4] = "recordP";
# (67-69) This should OVERWRITE the existing deferred record 
# and NOT flush the buffer
$a[5] = "recordQ";   
check_caches({3 => "recordZ$:", 2 => "recordE$:"},
             {5 => "recordQ$:", 4 => "recordP$:"}); 
check_contents(join("$:", qw(recordA recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");


# (70-72) Discard should just dump the whole deferbuffer
$o->discard;
check_caches({3 => "recordZ$:", 2 => "recordE$:"},
             {}); 
check_contents(join("$:", qw(recordA recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");
# (73-75) NOW we are out of deferred writing mode
$a[0] = "recordF";
check_caches({3 => "recordZ$:", 2 => "recordE$:", 0 => "recordF$:"},
             {}); 
check_contents(join("$:", qw(recordF recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");

# (76-79) Last call--untying the array should flush the deferbuffer
$o->defer;
$a[0] = "flushed";
check_caches({3 => "recordZ$:", 2 => "recordE$:"},
             {0 => "flushed$:" }); 
check_contents(join("$:", qw(recordF recordB recordE 
                             recordZ record4 record5 record6 record7)) . "$:");
undef $o;
untie @a;
# (79) We can't use check_contents any more, because the object is dead
open F, "< $file" or die;
binmode F;
{ local $/ ; $z = <F> }
close F;
my $x = join("$:", qw(flushed recordB recordE 
                      recordZ record4 record5 record6 record7)) . "$:";
if ($z eq $x) {
  print "ok $N\n";
} else {
  my $msg = ctrlfix("expected <$x>, got <$z>");
  print "not ok $N \# $msg\n";
}
$N++;

################################################################


sub check_caches {
  my ($xcache, $xdefer) = @_;

#  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
#  print $integrity ? "ok $N\n" : "not ok $N\n";
#  $N++;

  my $good = 1;
  $good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
  $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}

sub hash_equal {
  my ($a, $b, $ha, $hb) = @_;
  $ha = 'first hash'  unless defined $ha;
  $hb = 'second hash' unless defined $hb;

  my $good = 1;
  my %b_seen;

  for my $k (keys %$a) {
    if (! exists $b->{$k}) {
      print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
      $good = 0;
    } elsif ($b->{$k} ne $a->{$k}) {
      print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
      $b_seen{$k} = 1;
      $good = 0;
    } else {
      $b_seen{$k} = 1;
    }
  }

  for my $k (keys %$b) {
    unless ($b_seen{$k}) {
      print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
      $good = 0;
    }
  }

  $good;
}


sub check_contents {
  my $x = shift;

  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
  print $integrity ? "ok $N\n" : "not ok $N\n";
  $N++;

  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;

  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    my $msg = ctrlfix("# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;
}

sub ctrlfix {
  local $_ = shift;
  s/\n/\\n/g;
  s/\r/\\r/g;
  $_;
}

END {
  1 while unlink $file;
}
Commit	Line	Data
57c7bc08	1	#!/usr/bin/perl
	2	#
	3	# Check ->defer and ->flush methods
	4	#
	5
	6	use POSIX 'SEEK_SET';
	7	my $file = "tf$$.txt";
	8	$: = Tie::File::_default_recsep();
	9	my $data = "rec0$:rec1$:rec2$:";
	10	my ($o, $n);
	11
	12	print "1..79\n";
	13
	14	my $N = 1;
	15	use Tie::File;
	16	print "ok $N\n"; $N++;
	17
	18	open F, "> $file" or die $!;
	19	binmode F;
	20	print F $data;
	21	close F;
	22	$o = tie @a, 'Tie::File', $file;
	23	print $o ? "ok $N\n" : "not ok $N\n";
	24	$N++;
	25
	26	# (3-6) Deferred storage
	27	$o->defer;
	28	$a[3] = "rec3";
	29	check_contents($data); # nothing written yet
	30	$a[4] = "rec4";
	31	check_contents($data); # nothing written yet
	32
	33	# (7-8) Flush
	34	$o->flush;
	35	check_contents($data . "rec3$:rec4$:"); # now it's written
	36
	37	# (9-12) Deferred writing disabled?
	38	$a[3] = "rec9";
	39	check_contents("${data}rec9$:rec4$:");
	40	$a[4] = "rec8";
	41	check_contents("${data}rec9$:rec8$:");
	42
	43	# (13-18) Now let's try two batches of records
	44	$#a = 2;
	45	$o->defer;
	46	$a[0] = "record0";
	47	check_contents($data); # nothing written yet
	48	$a[2] = "record2";
	49	check_contents($data); # nothing written yet
	50	$o->flush;
	51	check_contents("record0$:rec1$:record2$:");
	52
	53	# (19-22) Deferred writing past the end of the file
	54	$o->defer;
	55	$a[4] = "record4";
	56	check_contents("record0$:rec1$:record2$:");
	57	$o->flush;
	58	check_contents("record0$:rec1$:record2$:$:record4$:");
	59
	60
	61	# (23-26) Now two long batches
	62	$o->defer;
	63	for (0..2, 4..6) {
	64	$a[$_] = "r$_";
65	}
66	check_contents("record0$:rec1$:record2$:$:record4$:");
67	$o->flush;
68	check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
69
70	# (27-30) Now let's make sure that discarded writes are really discarded
71	# We have a 2Mib buffer here, so we can be sure that we aren't accidentally
72	# filling it up
73	$o->defer;
74	for (0, 3, 7) {
75	$a[$_] = "discarded$_";
76	}
77	check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
78	$o->discard;
79	check_contents(join $:, "r0".."r2", "", "r4".."r6", "");
80
81	################################################################
82	#
83	# Now we're going to test the results of a small memory limit
84	#
85	#
86	undef $o; untie @a;
87	$data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long
88	open F, "> $file" or die $!;
89	binmode F;
90	print F $data;
91	close F;
92
93	# Limit cache+buffer size to 47 bytes
94	my $MAX = 47;
95	# -- that's enough space for 5 records, but not 6, on both \n and \r\n systems
96	my $BUF = 20;
97	# -- that's enough space for 2 records, but not 3, on both \n and \r\n systems
98	$o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF;
99	print $o ? "ok $N\n" : "not ok $N\n";
100	$N++;
101
102	# (31-32) Fill up the read cache
103	my @z;
104	@z = @a;
105	# the cache now contains records 3,4,5,6,7.
106	check_caches({map(($_ => "record$_$:"), 3..7)},
107	{});
108
109	# (33-44) See if overloading the defer starts by flushing the read cache
110	# and then flushes out the defer
111	$o->defer;
112	$a[0] = "recordA"; # That should flush record 3 from the cache
113	check_caches({map(($_ => "record$_$:"), 4..7)},
114	{0 => "recordA$:"});
115	check_contents($data);
116
117	$a[1] = "recordB"; # That should flush record 4 from the cache
118	check_caches({map(($_ => "record$_$:"), 5..7)},
119	{0 => "recordA$:",
120	1 => "recordB$:"});
121	check_contents($data);
122
123	$a[2] = "recordC"; # That should flush the whole darn defer
124	# Flushing the defer requires looking up the true lengths of records
125	# 0..2, which flushes out the read cache, leaving only 1..2 there.
126	# Then the splicer updates the cached versions of 1..2 to contain the
127	# new data
128	check_caches({1 => "recordB$:", 2 => "recordC$:"},
129	{}); # URRRP
130	check_contents(join("$:", qw(recordA recordB recordC
131	record3 record4 record5 record6 record7)) . "$:");
132
133	$a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED
134	check_caches({1 => "recordB$:", 2 => "recordC$:"},
135	{3 => "recordD$:"});
136	check_contents(join("$:", qw(recordA recordB recordC
137	record3 record4 record5 record6 record7)) . "$:");
138
139	# Check readcache-deferbuffer interactions
140
141	# (45-47) This should remove outdated data from the read cache
142	$a[2] = "recordE";
143	check_caches({1 => "recordB$:", },
144	{3 => "recordD$:", 2 => "recordE$:"});
145	check_contents(join("$:", qw(recordA recordB recordC
146	record3 record4 record5 record6 record7)) . "$:");
147
148	# (48-51) This should read back out of the defer buffer
149	# without adding anything to the read cache
150	my $z;
151	$z = $a[2];
152	print $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++;
153	check_caches({1 => "recordB$:", },
154	{3 => "recordD$:", 2 => "recordE$:"});
155	check_contents(join("$:", qw(recordA recordB recordC
156	record3 record4 record5 record6 record7)) . "$:");
157
158	# (52-55) This should repopulate the read cache with a new record
159	$z = $a[0];
160	print $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++;
161	check_caches({1 => "recordB$:", 0 => "recordA$:"},
162	{3 => "recordD$:", 2 => "recordE$:"});
163	check_contents(join("$:", qw(recordA recordB recordC
164	record3 record4 record5 record6 record7)) . "$:");
165
166	# (56-59) This should flush the LRU record from the read cache
167	$z = $a[4]; $z = $a[5];
168	print $z eq "record5" ? "ok $N\n" : "not ok $N\n"; $N++;
169	check_caches({5 => "record5$:", 0 => "recordA$:", 4 => "record4$:"},
170	{3 => "recordD$:", 2 => "recordE$:"});
171	check_contents(join("$:", qw(recordA recordB recordC
172	record3 record4 record5 record6 record7)) . "$:");
173
174	# (60-63) This should FLUSH the deferred buffer
175	# In doing so, it will read in records 2 and 3, flushing 0 and 4
176	# from the read cache, leaving 2, 3, and 5.
177	$z = splice @a, 3, 1, "recordZ";
178	print $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++;
179	check_caches({5 => "record5$:", 3 => "recordZ$:", 2 => "recordE$:"},
180	{});
181	check_contents(join("$:", qw(recordA recordB recordE
182	recordZ record4 record5 record6 record7)) . "$:");
183
184	# (64-66) We should STILL be in deferred writing mode
185	$a[5] = "recordX";
186	check_caches({3 => "recordZ$:", 2 => "recordE$:"},
187	{5 => "recordX$:"});
188	check_contents(join("$:", qw(recordA recordB recordE
189	recordZ record4 record5 record6 record7)) . "$:");
190
191	# Fill up the defer buffer again
192	$a[4] = "recordP";
193	# (67-69) This should OVERWRITE the existing deferred record
194	# and NOT flush the buffer
195	$a[5] = "recordQ";
196	check_caches({3 => "recordZ$:", 2 => "recordE$:"},
197	{5 => "recordQ$:", 4 => "recordP$:"});
198	check_contents(join("$:", qw(recordA recordB recordE
199	recordZ record4 record5 record6 record7)) . "$:");
200
201
202	# (70-72) Discard should just dump the whole deferbuffer
203	$o->discard;
204	check_caches({3 => "recordZ$:", 2 => "recordE$:"},
205	{});
206	check_contents(join("$:", qw(recordA recordB recordE
207	recordZ record4 record5 record6 record7)) . "$:");
208	# (73-75) NOW we are out of deferred writing mode
209	$a[0] = "recordF";
210	check_caches({3 => "recordZ$:", 2 => "recordE$:", 0 => "recordF$:"},
211	{});
212	check_contents(join("$:", qw(recordF recordB recordE
213	recordZ record4 record5 record6 record7)) . "$:");
214
215	# (76-79) Last call--untying the array should flush the deferbuffer
216	$o->defer;
217	$a[0] = "flushed";
218	check_caches({3 => "recordZ$:", 2 => "recordE$:"},
219	{0 => "flushed$:" });
220	check_contents(join("$:", qw(recordF recordB recordE
221	recordZ record4 record5 record6 record7)) . "$:");
222	undef $o;
223	untie @a;
224	# (79) We can't use check_contents any more, because the object is dead
225	open F, "< $file" or die;
d6b7ef86	226	binmode F;
57c7bc08	227	{ local $/ ; $z = <F> }
	228	close F;
	229	my $x = join("$:", qw(flushed recordB recordE
	230	recordZ record4 record5 record6 record7)) . "$:";
	231	if ($z eq $x) {
	232	print "ok $N\n";
	233	} else {
	234	my $msg = ctrlfix("expected <$x>, got <$z>");
	235	print "not ok $N \# $msg\n";
	236	}
	237	$N++;
	238
	239	################################################################
	240
	241
	242	sub check_caches {
	243	my ($xcache, $xdefer) = @_;
	244
	245	# my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
	246	# print $integrity ? "ok $N\n" : "not ok $N\n";
	247	# $N++;
	248
	249	my $good = 1;
	250	$good &&= hash_equal($o->{cache}, $xcache, "true cache", "expected cache");
	251	$good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer");
	252	print $good ? "ok $N\n" : "not ok $N\n";
	253	$N++;
	254	}
	255
	256	sub hash_equal {
	257	my ($a, $b, $ha, $hb) = @_;
	258	$ha = 'first hash' unless defined $ha;
	259	$hb = 'second hash' unless defined $hb;
	260
	261	my $good = 1;
	262	my %b_seen;
	263
	264	for my $k (keys %$a) {
	265	if (! exists $b->{$k}) {
	266	print ctrlfix("# Key $k is in $ha but not $hb"), "\n";
	267	$good = 0;
	268	} elsif ($b->{$k} ne $a->{$k}) {
	269	print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n";
	270	$b_seen{$k} = 1;
	271	$good = 0;
	272	} else {
	273	$b_seen{$k} = 1;
	274	}
	275	}
	276
	277	for my $k (keys %$b) {
	278	unless ($b_seen{$k}) {
	279	print ctrlfix("# Key $k is in $hb but not $ha"), "\n";
	280	$good = 0;
	281	}
	282	}
	283
	284	$good;
	285	}
	286
	287
	288	sub check_contents {
	289	my $x = shift;
	290
291	my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
292	print $integrity ? "ok $N\n" : "not ok $N\n";
293	$N++;
294
295	local *FH = $o->{fh};
296	seek FH, 0, SEEK_SET;
297
298	my $a;
299	{ local $/; $a = <FH> }
300	$a = "" unless defined $a;
301	if ($a eq $x) {
302	print "ok $N\n";
303	} else {
304	my $msg = ctrlfix("# expected <$x>, got <$a>");
305	print "not ok $N\n$msg\n";
306	}
307	$N++;
308	}
309
310	sub ctrlfix {
311	local $_ = shift;
312	s/\n/\\n/g;
313	s/\r/\\r/g;
314	$_;
315	}
316
317	END {
318	1 while unlink $file;
319	}
320