Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
00_version.t	356 B	-r--r--r--	2014-12-27 11:49
01_gen.t	3.83 KB	-r--r--r--	2014-12-27 11:48
02_fetchsize.t	828 B	-r--r--r--	2014-12-27 11:48
03_longfetch.t	906 B	-r--r--r--	2014-12-27 11:48
04_splice.t	7.52 KB	-r--r--r--	2014-12-27 11:48
05_size.t	2.38 KB	-r--r--r--	2014-12-27 11:48
06_fixrec.t	882 B	-r--r--r--	2014-12-27 11:48
07_rv_splice.t	5.31 KB	-r--r--r--	2014-12-27 11:48
08_ro.t	1.85 KB	-r--r--r--	2014-12-27 11:48
09_gen_rs.t	5.5 KB	-r--r--r--	2014-12-27 11:48
10_splice_rs.t	6.4 KB	-r--r--r--	2014-12-27 11:48
11_rv_splice_rs.t	4.85 KB	-r--r--r--	2014-12-27 11:48
12_longfetch_rs.t	650 B	-r--r--r--	2014-12-27 11:48
13_size_rs.t	1.51 KB	-r--r--r--	2014-12-27 11:48
14_lock.t	1007 B	-r--r--r--	2014-12-27 11:48
15_pushpop.t	3.08 KB	-r--r--r--	2014-12-27 11:48
16_handle.t	3.33 KB	-r--r--r--	2014-12-27 11:48
17_misc_meth.t	3.41 KB	-r--r--r--	2014-12-27 11:48
18_rs_fixrec.t	880 B	-r--r--r--	2014-12-27 11:48
19_cache.t	4.49 KB	-r--r--r--	2014-12-27 11:48
20_cache_full.t	5.35 KB	-r--r--r--	2014-12-27 11:48
21_win32.t	1.08 KB	-r--r--r--	2014-12-27 11:48
22_autochomp.t	3.94 KB	-r--r--r--	2014-12-27 11:48
23_rv_ac_splice.t	4.9 KB	-r--r--r--	2014-12-27 11:48
24_cache_loop.t	1.23 KB	-r--r--r--	2014-12-27 11:48
25_gen_nocache.t	3.02 KB	-r--r--r--	2014-12-27 11:48
26_twrite.t	16.82 KB	-r--r--r--	2014-12-27 11:48
27_iwrite.t	10.41 KB	-r--r--r--	2014-12-27 11:48
28_mtwrite.t	11.97 KB	-r--r--r--	2014-12-27 11:48
29_downcopy.t	16.81 KB	-r--r--r--	2014-12-27 11:48
29a_upcopy.t	4.78 KB	-r--r--r--	2014-12-27 11:48
30_defer.t	9.58 KB	-r--r--r--	2014-12-27 11:48
31_autodefer.t	4.58 KB	-r--r--r--	2014-12-27 11:48
32_defer_misc.t	4.99 KB	-r--r--r--	2014-12-27 11:48
33_defer_vs.t	2.76 KB	-r--r--r--	2014-12-27 11:48
40_abs_cache.t	5.33 KB	-r--r--r--	2014-12-27 11:48
41_heap.t	4.94 KB	-r--r--r--	2014-12-27 11:48
42_offset.t	1.51 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/usr/bin/perl
#
# Deferred caching of varying size records
#
# 30_defer.t always uses records that are 8 bytes long
# (9 on \r\n machines.)  We might miss some sort of
# length-calculation bug as a result.  This file will run some of the same
# tests, but with with varying-length records.
#

use POSIX 'SEEK_SET';
my $file = "tf$$.txt";
# print "1..0\n"; exit;
$: = Tie::File::_default_recsep();
my $data = "$:1$:22$:";
my ($o, $n);

print "1..30\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] = "333";
check_contents($data);          # nothing written yet
$a[4] = "4444";
check_contents($data);          # nothing written yet

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

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

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

# (19-22) Deferred writing past the end of the file
$o->defer;
$a[4] = "7777777";
check_contents("55555$:1$:aaaaaaaaaa$:");
$o->flush;
check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");

# (23-26) Now two long batches
$o->defer;
%l = qw(0 2  1 3  2 4  4 5  5 4  6 3);
for (0..2, 4..6) {
  $a[$_] = $_ x $l{$_};
}
check_contents("55555$:1$:aaaaaaaaaa$:$:7777777$:");
$o->flush;
check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");

# (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" . $_ x $_;
}
check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");
$o->discard;
check_contents(join $:, "00", "111", "2222", "", "44444", "5555", "666", "");

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

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 {
  undef $o;
  untie @a;
  1 while unlink $file;
}