dslinux/user/perl/lib/Tie/File/t 00_version.t 01_gen.t 02_fetchsize.t 03_longfetch.t 04_splice.t 05_size.t 06_fixrec.t 07_rv_splice.t 08_ro.t 09_gen_rs.t 10_splice_rs.t 11_rv_splice_rs.t 12_longfetch_rs.t 13_size_rs.t 14_lock.t 15_pushpop.t 16_handle.t 17_misc_meth.t 18_rs_fixrec.t 19_cache.t 20_cache_full.t 21_win32.t 22_autochomp.t 23_rv_ac_splice.t 24_cache_loop.t 25_gen_nocache.t 26_twrite.t 27_iwrite.t 28_mtwrite.t 29_downcopy.t 29a_upcopy.t 30_defer.t 31_autodefer.t 32_defer_misc.t 33_defer_vs.t 40_abs_cache.t 41_heap.t 42_offset.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:16 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/Tie/File/t
In directory antilope:/tmp/cvs-serv17422/lib/Tie/File/t

Added Files:
	00_version.t 01_gen.t 02_fetchsize.t 03_longfetch.t 
	04_splice.t 05_size.t 06_fixrec.t 07_rv_splice.t 08_ro.t 
	09_gen_rs.t 10_splice_rs.t 11_rv_splice_rs.t 12_longfetch_rs.t 
	13_size_rs.t 14_lock.t 15_pushpop.t 16_handle.t 17_misc_meth.t 
	18_rs_fixrec.t 19_cache.t 20_cache_full.t 21_win32.t 
	22_autochomp.t 23_rv_ac_splice.t 24_cache_loop.t 
	25_gen_nocache.t 26_twrite.t 27_iwrite.t 28_mtwrite.t 
	29_downcopy.t 29a_upcopy.t 30_defer.t 31_autodefer.t 
	32_defer_misc.t 33_defer_vs.t 40_abs_cache.t 41_heap.t 
	42_offset.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: 30_defer.t ---
#!/usr/bin/perl
#
# Check ->defer and ->flush methods
#
# This is the old version, which you used in the past when
# there was a defer buffer separate from the read cache.  
# There isn't any longer.
#

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
# This shouldn't change the cache contents
check_caches({map(($_ => "record$_$:"), 5..7)}, 
             {});               # 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({map(($_ => "record$_$:"), 5..7)},
             {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[5] = "recordE";
check_caches({6 => "record6$:", 7 => "record7$:"},
             {3 => "recordD$:", 5 => "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[5];
print $z eq "recordE" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({6 => "record6$:", 7 => "record7$:"},
             {3 => "recordD$:", 5 => "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({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"},
             {3 => "recordD$:", 5 => "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];
print $z eq "record4" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"},
             {3 => "recordD$:", 5 => "recordE$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             record3 record4 record5 record6 record7)) . "$:");

# (60-63) This should FLUSH the deferred buffer
$z = splice @a, 3, 1, "recordZ";
print $z eq "recordD" ? "ok $N\n" : "not ok $N\n";  $N++;
check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
             {}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             recordZ record4 recordE record6 record7)) . "$:");

# (64-66) We should STILL be in deferred writing mode
$a[5] = "recordX";
check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"},
             {5 => "recordX$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             recordZ record4 recordE 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({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
             {5 => "recordQ$:", 4 => "recordP$:"}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             recordZ record4 recordE record6 record7)) . "$:");

# (70-72) Discard should just dump the whole deferbuffer
$o->discard;
check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"},
             {}); 
check_contents(join("$:", qw(recordA recordB recordC 
                             recordZ record4 recordE record6 record7)) . "$:");

# (73-75) NOW we are out of deferred writing mode
$a[0] = "recordF";
check_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"},
             {}); 
check_contents(join("$:", qw(recordF recordB recordC
                             recordZ record4 recordE record6 record7)) . "$:");

# (76-79) Last call--untying the array should flush the deferbuffer
$o->defer;
$a[0] = "flushed";
check_caches({7 => "record7$:",                   3 => "recordZ$:"},
             {0 => "flushed$:" }); 
check_contents(join("$:", qw(recordF recordB recordC
                             recordZ record4 recordE 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 recordC
                      recordZ record4 recordE 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;

  # Copy the contents of the cache into a regular hash
  my %cache;
  for my $k ($o->{cache}->ckeys) {
    $cache{$k} = $o->{cache}->_produce($k);
  }

  $good &&= hash_equal(\%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 {
  undef $o;
  untie @a if tied @a;
  1 while unlink $file;
}


--- NEW FILE: 40_abs_cache.t ---
#!/usr/bin/perl
#
# Unit tests for abstract cache implementation
#
# Test the following methods:
# * new()
# * is_empty()
# * empty()
# * lookup(key)
# * remove(key)
# * insert(key,val)
# * update(key,val)
# * rekey(okeys,nkeys)
# * expire()
# * keys()
# * bytes()
# DESTROY()
#
# 20020327 You somehow managed to miss:
# * reduce_size_to(bytes)
#

# print "1..0\n"; exit;
print "1..42\n";

my ($N, @R, $Q, $ar) = (1);

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

my $h = Tie::File::Cache->new(10000) or die;
print "ok $N\n";
$N++;

# (3) Are all the methods there?
{
  my $good = 1;
  for my $meth (qw(new is_empty empty lookup remove
                 insert update rekey expire ckeys bytes
                   set_limit adj_limit flush  reduce_size_to
                   _produce _produce_lru )) {
    unless ($h->can($meth)) {
      print STDERR "# Method '$meth' is missing.\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}

# (4-5) Straight insert and removal FIFO test
$ar = 'a0';
for (1..10) {
  $h->insert($_, $ar++);
}
1;
for (1..10) {
  push @R, $h->expire;
}
$iota = iota('a',9);
print "@R" eq $iota
  ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
$N++;
check($h);

# (6-7) Remove from empty heap
$n = $h->expire;
print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
$N++;
check($h);

# (8-9) Interleaved insert and removal
$Q = 0;
@R = ();
for my $i (1..4) {
  for my $j (1..$i) {
    $h->insert($Q, "b$Q");
    $Q++;
  }
  for my $j (1..$i) {
    push @R, $h->expire;
  }
}
$iota = iota('b', 9);
print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
$N++;
check($h);

# (10) It should be empty now
print $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;

# (11-12) Insert and delete
$Q = 1;
for (1..10) {
  $h->insert($_, "c$Q");
  $Q++;
}
for (2, 4, 6, 8, 10) {
  $h->remove($_);
}
@R = ();
push @R, $n while defined ($n = $h->expire);
print "@R" eq "c1 c3 c5 c7 c9" ? 
  "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n";
$N++;
check($h);

# (13-14) Interleaved insert and delete
$Q = 1; my $QQ = 1;
@R = ();
for my $i (1..4) {
  for my $j (1..$i) {
    $h->insert($Q, "d$Q");
    $Q++;
  }
  for my $j (1..$i) {
    $h->remove($QQ) if $QQ % 2 == 0;
    $QQ++;
  }
}
push @R, $n while defined ($n = $h->expire);
print "@R" eq "d1 d3 d5 d7 d9" ? 
  "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n";
$N++;
check($h);

# (15-16) Promote
$h->empty;
$Q = 1;
for (1..10) {
  $h->insert($_, "e$Q");
  unless ($h->_check_integrity) {
    die "Integrity failed after inserting ($_, e$Q)\n";
  }
  $Q++;
}
1;
for (2, 4, 6, 8, 10) {
  $h->_promote($_);
}
@R = ();
push @R, $n while defined ($n = $h->expire);
print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ? 
    "ok $N\n" : 
    "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n";
$N++;
check($h);

# (17-22) Lookup
$Q = 1;
for (1..10) {
  $h->insert($_, "f$Q");
  $Q++;
}
1;
for (2, 4, 6, 4, 8) {
  my $r = $h->lookup($_);
  print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n";
  $N++;
}
check($h);

# (23) It shouldn't be empty
print ! $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;

# (24-25) Lookup should have promoted the looked-up records
@R = ();
push @R, $n while defined ($n = $h->expire);
print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ?
  "ok $N\n" : 
  "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n";
$N++;
check($h);

# (26-29) Typical 'rekey' operation
$Q = 1;
for (1..10) {
  $h->insert($_, "g$Q");
  $Q++;
}
$h->rekey([6,7,8,9,10], [8,9,10,11,12]);
my %x = qw(1 g1 2 g2  3 g3  4 g4  5 g5
           8 g6 9 g7 10 g8 11 g9 12 g10);
{
  my $good = 1;
  for my $k (keys %x) {
    my $v = $h->lookup($k);
    $v = "UNDEF" unless defined $v;
    unless ($v eq $x{$k}) {
      print "# looked up $k, got $v, expected $x{$k}\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}
check($h);
{
  my $good = 1;
  for my $k (6, 7) {
    my $v = $h->lookup($k);
    if (defined $v) {
      print "# looked up $k, got $v, should have been undef\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}
check($h);

# (30-31) ckeys
@R = sort { $a <=> $b } $h->ckeys;
print "@R" eq "1 2 3 4 5 8 9 10 11 12" ?
  "ok $N\n" : 
  "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n";
$N++;
check($h);
1;
# (32-33) update
for (1..5, 8..12) {
  $h->update($_, "h$_");
}
@R = ();
for (sort { $a <=> $b } $h->ckeys) {
  push @R, $h->lookup($_);
}
print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ?
  "ok $N\n" : 
  "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n";
$N++;
check($h);

# (34-37) bytes
my $B;
$B = $h->bytes;
print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n";
$N++;
check($h);
$h->update('12', "yobgorgle");
$B = $h->bytes;
print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n";
$N++;
check($h);

# (38-41) empty
$h->empty;
print $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;
check($h);
$n = $h->expire;
print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
$N++;
check($h);

# (42) very weak testing of DESTROY
undef $h;
# are we still alive?
print "ok $N\n";
$N++;

sub check {
  my $h = shift;
  print $h->_check_integrity ? "ok $N\n" : "not ok $N\n";
  $N++;
}

sub iota {
  my ($p, $n) = @_;
  my $r;
  my $i = 0;
  while ($i <= $n) {
    $r .= "$p$i ";
    $i++;
  }
  chop $r;
  $r;
}

--- NEW FILE: 31_autodefer.t ---
#!/usr/bin/perl
#
# Check behavior of 'autodefer' feature
# Mostly this isn't implemented yet
# This file is primarily here to make sure that the promised ->autodefer
# method doesn't croak.
#

use POSIX 'SEEK_SET';

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";
my ($o, $n, @a);

print "1..65\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++;

# I am an undocumented feature
$o->{autodefer_filelen_threshhold} = 0;
# Normally autodeferring only works on large files.  This disables that.

# (3-22) Deferred storage
$a[3] = "rec3";
check_autodeferring('OFF');
$a[4] = "rec4";
check_autodeferring('OFF');
$a[5] = "rec5";
check_autodeferring('ON');
check_contents($data . "rec3$:rec4$:"); # only the first two were written
$a[6] = "rec6";
check_autodeferring('ON');
check_contents($data . "rec3$:rec4$:"); # still nothing written
$a[7] = "rec7";
check_autodeferring('ON');
check_contents($data . "rec3$:rec4$:"); # still nothing written
$a[0] = "recX";
check_autodeferring('OFF');
check_contents("recX$:rec1$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
$a[1] = "recY";
check_autodeferring('OFF');
check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");
$a[2] = "recZ";                 # it kicks in here
check_autodeferring('ON');
check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:");

# (23-26) Explicitly enabling deferred writing deactivates autodeferring
$o->defer;
check_autodeferring('OFF');
check_contents("recX$:recY$:recZ$:rec3$:rec4$:rec5$:rec6$:rec7$:");
$o->discard;
check_autodeferring('OFF');

# (27-32) Now let's try the CLEAR special case
@a = ("r0" .. "r4");
check_autodeferring('ON');
# The file was extended to the right length, but nothing was actually written.
check_contents("$:$:$:$:$:");
$a[2] = "fish";
check_autodeferring('OFF');
check_contents("r0$:r1$:fish$:r3$:r4$:");

# (33-47) Now let's try the originally intended application:  a 'for' loop.
my $it = 0;
for (@a) {
  $_ = "##$_";
  if ($it == 0) {
    check_autodeferring('OFF');
    check_contents("##r0$:r1$:fish$:r3$:r4$:");
  } elsif ($it == 1) {
    check_autodeferring('OFF');
    check_contents("##r0$:##r1$:fish$:r3$:r4$:");
  } else {
    check_autodeferring('ON');
    check_contents("##r0$:##r1$:fish$:r3$:r4$:");
  }
  $it++;
}

# (48-56) Autodeferring should not become active during explicit defer mode
$o->defer();  # This should flush the pending autodeferred records
              # and deactivate autodeferring
check_autodeferring('OFF');
check_contents("##r0$:##r1$:##fish$:##r3$:##r4$:");
@a = ("s0" .. "s4");
check_autodeferring('OFF');
check_contents("");
$o->flush;
check_autodeferring('OFF');
check_contents("s0$:s1$:s2$:s3$:s4$:");

undef $o; untie @a;

# 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
# Re-tie the object for more tests
$o = tie @a, 'Tie::File', $file, autodefer => 0;
die $! unless $o;
# I am an undocumented feature
$o->{autodefer_filelen_threshhold} = 0;
# Normally autodeferring only works on large files.  This disables that.

# (57-59) Did the autodefer => 0 option work?
# (If it doesn't, a whole bunch of the other test files will fail.)
@a = (0..3);
check_autodeferring('OFF');
check_contents(join("$:", qw(0 1 2 3), ""));

# (60-62) Does the ->autodefer method work?
$o->autodefer(1);
@a = (10..13);
check_autodeferring('ON');
check_contents("$:$:$:$:");  # This might be unfortunate.

# (63-65) Does the ->autodefer method work?
$o->autodefer(0);
check_autodeferring('OFF');
check_contents(join("$:", qw(10 11 12 13), ""));


sub check_autodeferring {
  my ($x) = shift;
  my $a = $o->{autodeferring} ? 'ON' : 'OFF';
  if ($x eq $a) {
    print "ok $N\n";
  } else {
    print "not ok $N \# Autodeferring was $a, expected it to be $x\n";
  }
  $N++;
}


sub check_contents {
  my $x = shift;
#  for (values %{$o->{cache}}) {
#    print "# cache=$_";    
#  }
  
  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
  print $integrity ? "ok $N\n" : "not ok $N\n";
  $N++;
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 12_longfetch_rs.t ---
#!/usr/bin/perl
#
# Make sure we can fetch a record in the middle of the file
# before we've ever looked at any records before it
#
# (tests _fill_offsets_to() )
#

my $file = "tf$$.txt";
my $data = "rec0blahrec1blahrec2blah";

print "1..5\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;


my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# 3-5
for (2, 1, 0) {
  print $a[$_] eq "rec${_}blah" ? "ok $N\n" : "not ok $N # rec=$a[$_] ?\n";
  $N++;
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 15_pushpop.t ---
#!/usr/bin/perl
#
# Check PUSH, POP, SHIFT, and UNSHIFT 
#
# Each call to 'check_contents' actually performs two tests.
# First, it calls the tied object's own 'check_integrity' method,
# which makes sure that the contents of the read cache and offset tables
# accurately reflect the contents of the file.  
# Then, it checks the actual contents of the file against the expected
# contents.

use POSIX 'SEEK_SET';

my $file = "tf$$.txt";
1 while unlink $file;
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";

print "1..38\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
my ($n, @r);


# (3-11) PUSH tests
$n = push @a, "rec0", "rec1", "rec2";
check_contents($data);
print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
$N++;

$n = push @a, "rec3", "rec4$:";
check_contents("$ {data}rec3$:rec4$:");
print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
$N++;

# Trivial push
$n = push @a, ();
check_contents("$ {data}rec3$:rec4$:");
print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
$N++;

# (12-20) POP tests
$n = pop @a;
check_contents("$ {data}rec3$:");
print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
$N++;

# Presumably we have already tested this to death
splice(@a, 1, 3);
$n = pop @a;
check_contents("");
print $n eq "rec0$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec0\n";
$N++;

$n = pop @a;
check_contents("");
print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
$N++;


# (21-29) UNSHIFT tests
$n = unshift @a, "rec0", "rec1", "rec2";
check_contents($data);
print $n == 3 ? "ok $N\n" : "not ok $N # size is $n, should be 3\n";
$N++;

$n = unshift @a, "rec3", "rec4$:";
check_contents("rec3$:rec4$:$data");
print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
$N++;

# Trivial unshift
$n = unshift @a, ();
check_contents("rec3$:rec4$:$data");
print $n == 5 ? "ok $N\n" : "not ok $N # size is $n, should be 5\n";
$N++;

# (30-38) SHIFT tests
$n = shift @a;
check_contents("rec4$:$data");
print $n eq "rec3$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec3\n";
$N++;

# Presumably we have already tested this to death
splice(@a, 1, 3);
$n = shift @a;
check_contents("");
print $n eq "rec4$:" ? "ok $N\n" : "not ok $N # last rec is $n, should be rec4\n";
$N++;

$n = shift @a;
check_contents("");
print ! defined $n ? "ok $N\n" : "not ok $N # last rec should be undef, is $n\n";
$N++;


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 {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 42_offset.t ---
#!/usr/bin/perl

# 2003-04-09 Tels: test the offset method from 0.94

use Test::More;
use strict;
use File::Spec;

use POSIX 'SEEK_SET';
my $file = "tf$$.txt";

BEGIN
  {
  $| = 1;
  if ($ENV{PERL_CORE})
    {
    # testing with the core distribution
    @INC = ( File::Spec->catdir(File::Spec->updir, 't', 'lib') );
    }
  unshift @INC, File::Spec->catdir(File::Spec->updir, 'lib');
  chdir 't' if -d 't';
  print "# INC = @INC\n";

  plan tests => 24;

  use_ok ('Tie::File');
  }

$/ = "#";	# avoid problems with \n\r vs. \n

my @a;
my $o = tie @a, 'Tie::File', $file, autodefer => 0;

is (ref($o), 'Tie::File');

is ($o->offset(0), 0, 'first one always there');
is ($o->offset(1), undef, 'no offsets yet');

$a[0] = 'Bourbon';
is ($o->offset(0), 0, 'first is ok');
is ($o->offset(1), 8, 'and second ok');
is ($o->offset(2), undef, 'third undef');

$a[1] = 'makes';
is ($o->offset(0), 0, 'first is ok');
is ($o->offset(1), 8, 'and second ok');
is ($o->offset(2), 14, 'and third ok');
is ($o->offset(3), undef, 'fourth undef');

$a[2] = 'the baby';
is ($o->offset(0), 0, 'first is ok');
is ($o->offset(1), 8, 'and second ok');
is ($o->offset(2), 14, 'and third ok');
is ($o->offset(3), 23, 'and fourth ok');
is ($o->offset(4), undef, 'fourth undef');

$a[3] = 'grin';
is ($o->offset(0), 0, 'first is ok');
is ($o->offset(1), 8, 'and second ok');
is ($o->offset(2), 14, 'and third ok');
is ($o->offset(3), 23, 'and fourth ok');
is ($o->offset(4), 28, 'and fifth ok');

$a[4] = '!';
is ($o->offset(5), 30, 'and fifth ok');
$a[3] = 'water';
is ($o->offset(4), 29, 'and fourth changed ok');
is ($o->offset(5), 31, 'and fifth ok');

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}

--- NEW FILE: 05_size.t ---
#!/usr/bin/perl
#
# Check FETCHSIZE and SETSIZE functions
# PUSH POP SHIFT UNSHIFT
#

use POSIX 'SEEK_SET';

my $file = "tf$$.txt";
my ($o, $n);

print "1..16\n";

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

# 2-3 FETCHSIZE 0-length file
open F, "> $file" or die $!;
binmode F;
close F;
$o = tie @a, 'Tie::File', $file;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};

$n = @a;
print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
$N++;

# Reset everything
undef $o;
untie @a;

my $data = "rec0$:rec1$:rec2$:";
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++;

# 4-5 FETCHSIZE positive-length file
$n = @a;
print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
$N++;

# STORESIZE
# (6-7) Make it longer:
populate();
$#a = 4;
check_contents("$data$:$:");

# (8-9) Make it longer again:
populate();
$#a = 6;
check_contents("$data$:$:$:$:");

# (10-11) Make it shorter:
populate();
$#a = 4;
check_contents("$data$:$:");

# (12-13) Make it shorter again:
populate();
$#a = 2;
check_contents($data);

# (14-15) Get rid of it completely:
populate();
$#a = -1;
check_contents('');

# (16) 20020324 I have an idea that shortening the array will not
# expunge a cached record at the end if one is present.
$o->defer;
$a[3] = "record";
my $r = $a[3];
$#a = -1;
$r = $a[3];
print (! defined $r ? "ok $N\n" : "not ok $N \# was <$r>; should be UNDEF\n");
# Turns out not to be the case---STORESIZE explicitly removes them later
# 20020326 Well, but happily, this test did fail today.

# In the past, there was a bug in STORESIZE that it didn't correctly
# remove deleted records from the cache.  This wasn't detected
# because these tests were all done with an empty cache.  populate()
# will ensure that the cache is fully populated.
sub populate {
  my $z;
  $z = $a[$_] for 0 .. $#a;
}

sub check_contents {
  my $x = shift;
  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 {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;
  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
  print $integrity ? "ok $N\n" : "not ok $N \# integrity\n";
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 16_handle.t ---
#!/usr/bin/perl
#
# Basic operation, initializing the object from an already-open handle
# instead of from a filename

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();

if ($^O =~ /vms/i) {
  print "1..0\n";
  exit;
}

print "1..39\n";

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

use Fcntl 'O_CREAT', 'O_RDWR';
sysopen F, $file, O_CREAT | O_RDWR 
  or die "Couldn't create temp file $file: $!; aborting";
binmode F;

my $o = tie @a, 'Tie::File', \*F, autochomp => 0, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# 3-4 create
$a[0] = 'rec0';
check_contents("rec0");

# 5-8 append
$a[1] = 'rec1';
check_contents("rec0", "rec1");
$a[2] = 'rec2';
check_contents("rec0", "rec1", "rec2");

# 9-14 same-length alterations
$a[0] = 'new0';
check_contents("new0", "rec1", "rec2");
$a[1] = 'new1';
check_contents("new0", "new1", "rec2");
$a[2] = 'new2';
check_contents("new0", "new1", "new2");

# 15-24 lengthening alterations
$a[0] = 'long0';
check_contents("long0", "new1", "new2");
$a[1] = 'long1';
check_contents("long0", "long1", "new2");
$a[2] = 'long2';
check_contents("long0", "long1", "long2");
$a[1] = 'longer1';
check_contents("long0", "longer1", "long2");
$a[0] = 'longer0';
check_contents("longer0", "longer1", "long2");

# 25-38 shortening alterations, including truncation
$a[0] = 'short0';
check_contents("short0", "longer1", "long2");
$a[1] = 'short1';
check_contents("short0", "short1", "long2");
$a[2] = 'short2';
check_contents("short0", "short1", "short2");
$a[1] = 'sh1';
check_contents("short0", "sh1", "short2");
$a[0] = 'sh0';
check_contents("sh0", "sh1", "short2");

# file with holes
$a[4] = 'rec4';
check_contents("sh0", "sh1", "short2", "", "rec4");
$a[3] = 'rec3';
check_contents("sh0", "sh1", "short2", "rec3", "rec4");

close F;
undef $o;
untie @a;

# (39) Does it correctly detect a non-seekable handle?
{  if ($^O =~ /^(MSWin32|dos|beos)$/) {
     print "ok $N # skipped ($^O has broken pipe semantics)\n";
     last;
   }
   if ($] < 5.006) {
     print "ok $N # skipped - 5.005_03 panics after this test\n";
     last;
   }
   my $pipe_succeeded = eval {pipe *R, *W};
   if ($@) {
     chomp $@;
     print "ok $N # skipped (no pipes: $@)\n";
     last;
   } elsif (! $pipe_succeeded) {
     print "ok $N # skipped (pipe call failed: $!)\n";
     last;
   }
   close R;
   $o = eval {tie @a, 'Tie::File', \*W};
   if ($@) {
     if ($@ =~ /filehandle does not appear to be seekable/) {
       print "ok $N\n";
     } else {
       chomp $@;
       print "not ok $N \# \$\@ is $@\n";
     }
   } else {
       print "not ok $N \# passing pipe to TIEARRAY didn't abort program\n";
   }
   $N++;
}

use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    unless ($a[$_] eq "$c[$_]$:") {
      $msg = "expected $c[$_]$:, got $a[$_]";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}



--- NEW FILE: 23_rv_ac_splice.t ---
#!/usr/bin/perl
#
# Check SPLICE function's return value when autochoping is now
# (07_rv_splice.t checks it aith autochomping off)
#

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";

print "1..50\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

init_file($data);

my $o = tie @a, 'Tie::File', $file, autochomp => 1;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# (3-12) splicing at the beginning
@r = splice(@a, 0, 0, "rec4");
check_result();
@r = splice(@a, 0, 1, "rec5");       # same length
check_result("rec4");
@r = splice(@a, 0, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, 0, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 0, 1);               # removal
check_result("r5");
@r = splice(@a, 0, 0);               # no-op
check_result();
@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 0, 2);               # delete more than one
check_result('record9', 'rec10');


# (13-22) splicing in the middle
@r = splice(@a, 1, 0, "rec4");
check_result();
@r = splice(@a, 1, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 1, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 1, 1);               # removal
check_result("r5");
@r = splice(@a, 1, 0);               # no-op
check_result();
@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 1, 2);               # delete more than one
check_result('record9','rec10');

# (23-32) splicing at the end
@r = splice(@a, 3, 0, "rec4");
check_result();
@r = splice(@a, 3, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 3, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 3, 1, "r5");         # shorter
check_result('record5');
@r = splice(@a, 3, 1);               # removal
check_result('r5');
@r = splice(@a, 3, 0);               # no-op
check_result();
@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 3, 2);               # delete more than one
check_result('record9', 'rec10');

# (33-42) splicing with negative subscript
@r = splice(@a, -1, 0, "rec4");
check_result();
@r = splice(@a, -1, 1, "rec5");       # same length
check_result('rec2');
@r = splice(@a, -1, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, -1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, -1, 1);               # removal
check_result("r5");
@r = splice(@a, -1, 0);               # no-op  
check_result();
@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('rec4');

@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, -4, 3);               # delete more than one
check_result('r7', 'rec8', 'record9');

# (43) scrub it all out
@r = splice(@a, 0, 3);
check_result('rec0', 'rec1', 'rec10');

# (44) put some back in
@r = splice(@a, 0, 0, "rec0", "rec1");
check_result();

# (45) what if we remove too many records?
@r = splice(@a, 0, 17);
check_result('rec0', 'rec1');

# (46-48) Now check the scalar context return
splice(@a, 0, 0, qw(I like pie));
my $r;
$r = splice(@a, 0, 0);
print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n";
$N++;

$r = splice(@a, 2, 1);
print $r eq "pie" ? "ok $N\n" : "not ok $N \# return should have been 'pie', was <$r>\n";
$N++;

$r = splice(@a, 0, 2);
print $r eq "like" ? "ok $N\n" : "not ok $N \# return should have been 'like', was <$r>\n";
$N++;

# (49-50) Test default arguments
splice @a, 0, 0, (0..11);
@r = splice @a, 4;
check_result(4..11);
@r = splice @a;
check_result(0..3);

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

# actual results are in @r.
# expected results are in @_
sub check_result {
  my @x = @_;
  my $good = 1;
  $good = 0 unless @r == @x;
  for my $i (0 .. $#r) {
    $good = 0 unless $r[$i] eq $x[$i];
  }
  print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
  $N++;
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 27_iwrite.t ---
#!/usr/bin/perl
#
# Unit tests of _iwrite function
#
# _iwrite($self, $data, $start, $end)
#
# 'i' here is for 'insert'.  This writes $data at absolute position $start
# in the file, copying the data at that position downwards---
# but only down to position $end.  Data at or past $end is not moved
# or even examined.    Since there isn't enough room for the full copy
# (Because we inserted $data at the beginning) we copy as much as possible
# and return a string containing the remainder.

my $file = "tf$$.txt";
$| = 1;

print "1..203\n";

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

$: = Tie::File::_default_recsep();

$FLEN = 40970;   # Use files of this length
$oldfile = mkrand($FLEN);
print "# MOF tests\n";
# (2-85) These were generated by 'gentests.pl' to cover all possible cases
# (I hope)
# Legend:
#         x: data is entirely contained within one block
#        x>: data runs from the middle to the end of the block
#        <x: data runs from the start to the middle of the block
#       <x>: data occupies precisely one block
#      x><x: data overlaps one block boundary
#     <x><x: data runs from the start of one block into the middle of the next
#     x><x>: data runs from the middle of one block to the end of the next
#    <x><x>: data occupies two blocks exactly
# <x><x><x>: data occupies three blocks exactly
#         0: data is null
#
# For each possible alignment of the old and new data, we investigate
# up to three situations: old data is shorter, old and new data are the
# same length, and new data is shorter.
#
# try($pos, $old, $new) means to run a test where the area being
# written into starts at position $pos, the area being written into
# has length $old, and and the new data has length $new.
try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try( 8771,   776,     0);  # old=x        , new=0        ; old > new
try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(10489,     0,     0);  # old=0        , new=0        ; old = new

print "# SOF tests\n";
# (86-133)
# These tests all take place at the start of the file
try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(    0,     0,     0);  # old=0        , new=0        ; old = new

print "# EOF tests 1\n";
# (134-169)
# These tests all take place at the end of the file
$FLEN = 40960;  # Force the file to be exactly 40960 bytes long
$oldfile = mkrand($FLEN);
try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(40960,     0,     0);  # old=0        , new=0        ; old = new

print "# EOF tests 2\n";
# (170-203)
# These tests all take place at the end of the file
$FLEN = 42000;  # Force the file to be exactly 42000 bytes long
$oldfile = mkrand($FLEN);
try(41683,   317,   317);  # old=x        , new=x        ; old = new
try(41225,   775,   405);  # old=x        , new=x        ; old > new
try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
try(41500,   500,     0);  # old=x        , new=0        ; old > new
try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
try(42000,     0,     0);  # old=0        , new=0        ; old = new

sub mkrand {
  my $len = shift;
  srand $len;
  my @c = ('a' .. 'z', 'A' .. 'Z', 0..9, $:);
  my $d = "";
  $d .= $c[rand @c] until length($d) >= $len;
  substr($d, $len) = ""; # chop it off to the proper length
  $d;
}

sub try {
  my ($s, $len, $newlen) = @_;
  my $e = $s + $len;

  open F, "> $file" or die "Couldn't open file $file: $!";
  binmode F;

  print F $oldfile;
  close F;

  die "wrong length!" unless -s $file == $FLEN;

  my $newdata = "-" x $newlen;
  my $expected = $oldfile;

  my $expected_return = substr($expected, $e - $newlen, $newlen, "");
  substr($expected, $s, 0, $newdata);

  my $o = tie my @lines, 'Tie::File', $file or die $!;
  my $actual_return = $o->_iwrite($newdata, $s, $e);
  undef $o; untie @lines;

  open F, "< $file" or die "Couldn't open file $file: $!";
  binmode F;
  my $actual;
  { local $/;
    $actual = <F>;
  }
  close F;

  my ($alen, $xlen) = (length $actual, length $expected);
  unless ($alen == $xlen) {
    print "# try(@_) expected file length $xlen, actual $alen!\n";
  }
  print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
  $N++;

  if (! defined $actual_return && ! defined $expected_return) {
    print "ok $N\n";
  } elsif (! defined $actual_return || ! defined $expected_return) {
    print "not ok $N\n";
  } else {
    print $actual_return eq $expected_return ? "ok $N\n" : "not ok $N\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  1 while unlink $file;
}


--- NEW FILE: 32_defer_misc.t ---
#!/usr/bin/perl
#
# Check interactions of deferred writing
# with miscellaneous methods like DELETE, EXISTS,
# FETCHSIZE, STORESIZE, CLEAR, EXTEND
#

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

print "1..53\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) EXISTS
if ($] >= 5.006) {
  eval << 'TESTS';
$o->defer;
expect(not exists $a[4]);
$a[4] = "rec4";
expect(exists $a[4]);
check_contents($data);          # nothing written yet
$o->discard;
TESTS
} else {
    for (3..6) {
      print "ok $_ \# skipped (no exists for arrays)\n";
          $N++;
    }
}

# (7-10) FETCHSIZE
$o->defer;
expect($#a, 2);
$a[4] = "rec4";
expect($#a, 4);
check_contents($data);          # nothing written yet
$o->discard;

# (11-21) STORESIZE
$o->defer;
$#a = 4;
check_contents($data);          # nothing written yet
expect($#a, 4);
$o->flush;
expect($#a, 4);
check_contents("$data$:$:");    # two extra empty records

$o->defer;
$a[4] = "rec4";
$#a = 2;
expect($a[4], undef);
check_contents($data);          # written data was unwritten
$o->flush;
check_contents($data);          # nothing left to write

# (22-28) CLEAR
$o->defer;
$a[9] = "rec9";
check_contents($data);          # nothing written yet
@a = ();
check_contents("");             # this happens right away
expect($a[9], undef);
$o->flush;
check_contents("");             # nothing left to write

# (29-34) EXTEND
# Actually it's not real clear what these tests are for
# since EXTEND has no defined semantics
$o->defer;
@a = (0..3);
check_contents("");             # nothing happened yet
expect($a[3], "3");
expect($a[4], undef);
$o->flush;
check_contents("0$:1$:2$:3$:"); # file now 4 records long

# (35-53) DELETE
if ($] >= 5.006) {
  eval << 'TESTS';
my $del;
$o->defer;
$del = delete $a[2];
check_contents("0$:1$:2$:3$:"); # nothing happened yet
expect($a[2], "");
expect($del, "2");
$del = delete $a[3];            # shortens file!
check_contents("0$:1$:2$:");    # deferred writes NOT flushed
expect($a[3], undef);
expect($a[2], "");
expect($del, "3");
$a[2] = "cookies";
$del = delete $a[2];            # shortens file!
expect($a[2], undef);
expect($del, 'cookies');
check_contents("0$:1$:");
$a[0] = "crackers";
$del = delete $a[0];            # file unchanged
expect($a[0], "");
expect($del, 'crackers');
check_contents("0$:1$:");       # no change yet
$o->flush;
check_contents("$:1$:");        # record 0 is NOT 'cookies';
TESTS
} else {
    for (35..53) {
      print "ok $_ \# skipped (no delete for arrays)\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 expect {
  if (@_ == 1) {
    print $_[0] ? "ok $N\n" : "not ok $N\n";
  } elsif (@_ == 2) {
    my ($a, $x) = @_;
    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
    elsif (  defined($a) && ! defined($x)) { 
      ctrlfix(my $msg = "expected UNDEF, got <$a>");
      print "not ok $N \# $msg\n";
    }
    elsif (! defined($a) &&   defined($x)) { 
      ctrlfix(my $msg = "expected <$x>, got UNDEF");
      print "not ok $N \# $msg\n";
    } elsif ($a eq $x) { print "ok $N\n" }
    else {
      ctrlfix(my $msg = "expected <$x>, got <$a>");
      print "not ok $N \# $msg\n";
    }
  } else {
    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
  }
  $N++;
}

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

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 21_win32.t ---
#!/usr/bin/perl
#
# Formerly, on a Win32 system, Tie::File would create files with
# \n-terminated records instead of \r\n-terminated.  The tests never
# picked this up because they were using $/ everywhere, and $/ is \n
# on windows systems.
#
# These tests (Win32 only) make sure that the file had \r\n as it should.

my $file = "tf$$.txt";

unless ($^O =~ /^(MSWin32|dos)$/) {
  print "1..0\n";
  exit;
}


print "1..3\n";

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

my $o = tie @a, 'Tie::File', $file, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# (3) Make sure that on Win32 systems, the file is written with \r\n by default
@a = qw(fish dog carrot);
undef $o;
untie @a;
open F, "< $file" or die "Couldn't open file $file: $!";
binmode F;
my $a = do {local $/ ; <F> };
my $x = "fish\r\ndog\r\ncarrot\r\n" ;
if ($a eq $x) {
  print "ok $N\n";
} else {
  ctrlfix(my $msg = "expected <$x>, got <$a>");
  print "not ok $N # $msg\n";
}

close F;

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}



END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 09_gen_rs.t ---
#!/usr/bin/perl

my $file = "tf$$.txt";

print "1..59\n";

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

$RECSEP = 'blah';
my $o = tie @a, 'Tie::File', $file, 
    recsep => $RECSEP, autochomp => 0, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;


# 3-4 create
$a[0] = 'rec0';
check_contents("rec0");

# 5-8 append
$a[1] = 'rec1';
check_contents("rec0", "rec1");
$a[2] = 'rec2';
check_contents("rec0", "rec1", "rec2");

# 9-14 same-length alterations
$a[0] = 'new0';
check_contents("new0", "rec1", "rec2");
$a[1] = 'new1';
check_contents("new0", "new1", "rec2");
$a[2] = 'new2';
check_contents("new0", "new1", "new2");

# 15-24 lengthening alterations
$a[0] = 'long0';
check_contents("long0", "new1", "new2");
$a[1] = 'long1';
check_contents("long0", "long1", "new2");
$a[2] = 'long2';
check_contents("long0", "long1", "long2");
$a[1] = 'longer1';
check_contents("long0", "longer1", "long2");
$a[0] = 'longer0';
check_contents("longer0", "longer1", "long2");

# 25-34 shortening alterations, including truncation
$a[0] = 'short0';
check_contents("short0", "longer1", "long2");
$a[1] = 'short1';
check_contents("short0", "short1", "long2");
$a[2] = 'short2';
check_contents("short0", "short1", "short2");
$a[1] = 'sh1';
check_contents("short0", "sh1", "short2");
$a[0] = 'sh0';
check_contents("sh0", "sh1", "short2");

# (35-38) file with holes
$a[4] = 'rec4';
check_contents("sh0", "sh1", "short2", "", "rec4");
$a[3] = 'rec3';
check_contents("sh0", "sh1", "short2", "rec3", "rec4");

# (39-40) zero out file
@a = ();
check_contents();

# (41-42) insert into the middle of an empty file
$a[3] = "rec3";
check_contents("", "", "", "rec3");

# (43-47) 20020326 You thought there would be a bug in STORE where if
# a cached record was false, STORE wouldn't see it at all.  Yup, there is,
# and adding the appropriate defined() test fixes the problem.
undef $o;  untie @a;  1 while unlink $file;
$RECSEP = '0';
$o = tie @a, 'Tie::File', $file, 
    recsep => $RECSEP, autochomp => 0, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
$#a = 2;
my $z = $a[1];                  # caches "0"
$a[2] = "oops";
check_contents("", "", "oops");
$a[1] = "bah";
check_contents("", "bah", "oops");
undef $o; untie @a;

# (48-56) 20020331 Make sure we correctly handle the case where the final
# record of the file is not properly terminated, Through version 0.90,
# we would mangle the file.
my $badrec = "Malformed";
$: = $RECSEP = Tie::File::_default_recsep();
# (48-50)
if (setup_badly_terminated_file(3)) {
  $o = tie @a, 'Tie::File', $file,
    recsep => $RECSEP, autochomp => 0, autodefer => 0
    or die "Couldn't tie file: $!";
  my $z = $a[0];
  print $z eq "$badrec$:" ? "ok $N\n" : 
                        "not ok $N \# got $z, expected $badrec\n";
  $N++;
  push @a, "next";
  check_contents($badrec, "next");
}
# (51-52)
if (setup_badly_terminated_file(2)) {
  $o = tie @a, 'Tie::File', $file,
    recsep => $RECSEP, autochomp => 0, autodefer => 0
    or die "Couldn't tie file: $!";
  splice @a, 1, 0, "x", "y";
  check_contents($badrec, "x", "y");
}
# (53-56)
if (setup_badly_terminated_file(4)) {
  $o = tie @a, 'Tie::File', $file,
    recsep => $RECSEP, autochomp => 0, autodefer => 0
    or die "Couldn't tie file: $!";
  my @r = splice @a, 0, 1, "x", "y";
  my $n = @r;
  print $n == 1 ? "ok $N\n" : "not ok $N \# expected 1 elt, got $n\n";
  $N++;
  print $r[0] eq "$badrec$:" ? "ok $N\n"
    : "not ok $N \# expected <$badrec>, got <$r[0]>\n";
  $N++;
  check_contents("x", "y");
}

# (57-58) 20020402 The modification would have failed if $\ were set wrong.
# I hate $\.
if (setup_badly_terminated_file(2)) {
  $o = tie @a, 'Tie::File', $file,
    recsep => $RECSEP, autochomp => 0, autodefer => 0
    or die "Couldn't tie file: $!";
  { local $\ = "I hate \$\\.";
    my $z = $a[0];
  }
  check_contents($badrec);
}

# (59) 20030527 Tom Christiansen pointed out that FETCH returns the wrong
# data on the final record of an unterminated file if the file is opened
# in read-only mode.  Note that the $#a is necessary here.
# There's special-case code to fix the final record when it is read normally.
# But the $#a forces it to be read from the cache, which skips the
# termination.
$badrec = "world${RECSEP}hello";
if (setup_badly_terminated_file(1)) {
  tie(@a, "Tie::File", $file, mode => 0, recsep => $RECSEP)
      or die "Couldn't tie file: $!";
  my $z = $#a;
  $z = $a[1];
  print $z eq "hello" ? "ok $N\n" : 
      "not ok $N \# got $z, expected hello\n";
  $N++;
}

sub setup_badly_terminated_file {
  my $NTESTS = shift;
  open F, "> $file" or die "Couldn't open $file: $!";
  binmode F;
  print F $badrec;
  close F;
  unless (-s $file == length $badrec) {
    for (1 .. $NTESTS) {
      print "ok $N \# skipped - can't create improperly terminated file\n";
      $N++;
    }
    return;
  }
  return 1;
}


use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $RECSEP, @c, '';
  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 = "# expected <$x>, got <$a>";
    ctrlfix($msg);
    print "not ok $N $msg\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  for (0.. $#c) {
    unless ($a[$_] eq "$c[$_]$RECSEP") {
      $msg = "expected $c[$_]$RECSEP, got $a[$_]";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # fetch $msg\n";
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}


END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 08_ro.t ---
#!/usr/bin/perl
#
# Make sure it works to open the file in read-only mode
#

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();

print "1..13\n";

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

my @items = qw(Gold Frankincense Myrrh Ivory Apes Peacocks);
init_file(join $:, @items, '');

my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$#a == $#items ? print "ok $N\n" : print "not ok $N\n";
$N++;

for my $i (0..$#items) {
  ("$items[$i]$:" eq $a[$i]) ? print "ok $N\n" : print "not ok $N\n";
  $N++;
}

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

undef $o; untie @a;
my $badrec = "Malformed";
# (10-13) When a record lacks the record seprator, we sneakily try
# to fix it.  How does that work when the file is read-only?
if (setup_badly_terminated_file(4)) {
  my $good = 1;
  my $warn;
  local $SIG{__WARN__} = sub { $good = 0; ctrlfix($warn = shift); };
  local $^W = 1;
  my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0
    or die "Couldn't tie $file: $!";

  print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n";  $N++;
  print $good ? "ok $N\n" : "not ok $N # $warn\n";  $good = 1; $N++;
  print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n";  $N++;
  print $good ? "ok $N\n" : "not ok $N # $warn\n";  $good = 1; $N++;
}

sub setup_badly_terminated_file {
  my $NTESTS = shift;
  open F, "> $file" or die "Couldn't open $file: $!";
  binmode F;
  print F $badrec;
  close F;
  unless (-s $file == length $badrec) {
    for (1 .. $NTESTS) {
      print "ok $N \# skipped - can't create improperly terminated file\n";
      $N++;
    }
    return;
  }
  return 1;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 10_splice_rs.t ---
#!/usr/bin/perl
#
# Check SPLICE function's effect on the file
# (07_rv_splice.t checks its return value)
#
# Each call to 'check_contents' actually performs two tests.
# First, it calls the tied object's own 'check_integrity' method,
# which makes sure that the contents of the read cache and offset tables
# accurately reflect the contents of the file.  
# Then, it checks the actual contents of the file against the expected
# contents.

use POSIX 'SEEK_SET';

my $file = "tf$$.txt";
my $data = "rec0blahrec1blahrec2blah";

print "1..101\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

init_file($data);

my $o = tie @a, 'Tie::File', $file, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# (3-22) splicing at the beginning
splice(@a, 0, 0, "rec4");
check_contents("rec4blah$data");
splice(@a, 0, 1, "rec5");       # same length
check_contents("rec5blah$data");
splice(@a, 0, 1, "record5");    # longer
check_contents("record5blah$data");

splice(@a, 0, 1, "r5");         # shorter
check_contents("r5blah$data");
splice(@a, 0, 1);               # removal
check_contents("$data");
splice(@a, 0, 0);               # no-op
check_contents("$data");
splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check_contents("r7blahrec8blah$data");
splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec7blahrecord8blahrec9blah$data");

splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check_contents("record9blahrec10blah$data");
splice(@a, 0, 2);               # delete more than one
check_contents("$data");


# (23-42) splicing in the middle
splice(@a, 1, 0, "rec4");
check_contents("rec0blahrec4blahrec1blahrec2blah");
splice(@a, 1, 1, "rec5");       # same length
check_contents("rec0blahrec5blahrec1blahrec2blah");
splice(@a, 1, 1, "record5");    # longer
check_contents("rec0blahrecord5blahrec1blahrec2blah");

splice(@a, 1, 1, "r5");         # shorter
check_contents("rec0blahr5blahrec1blahrec2blah");
splice(@a, 1, 1);               # removal
check_contents("$data");
splice(@a, 1, 0);               # no-op
check_contents("$data");
splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check_contents("rec0blahr7blahrec8blahrec1blahrec2blah");
splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec0blahrec7blahrecord8blahrec9blahrec1blahrec2blah");

splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check_contents("rec0blahrecord9blahrec10blahrec1blahrec2blah");
splice(@a, 1, 2);               # delete more than one
check_contents("$data");

# (43-62) splicing at the end
splice(@a, 3, 0, "rec4");
check_contents("$ {data}rec4blah");
splice(@a, 3, 1, "rec5");       # same length
check_contents("$ {data}rec5blah");
splice(@a, 3, 1, "record5");    # longer
check_contents("$ {data}record5blah");

splice(@a, 3, 1, "r5");         # shorter
check_contents("$ {data}r5blah");
splice(@a, 3, 1);               # removal
check_contents("$data");
splice(@a, 3, 0);               # no-op
check_contents("$data");
splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check_contents("$ {data}r7blahrec8blah");
splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("$ {data}rec7blahrecord8blahrec9blah");

splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check_contents("$ {data}record9blahrec10blah");
splice(@a, 3, 2);               # delete more than one
check_contents("$data");

# (63-82) splicing with negative subscript
splice(@a, -1, 0, "rec4");
check_contents("rec0blahrec1blahrec4blahrec2blah");
splice(@a, -1, 1, "rec5");       # same length
check_contents("rec0blahrec1blahrec4blahrec5blah");
splice(@a, -1, 1, "record5");    # longer
check_contents("rec0blahrec1blahrec4blahrecord5blah");

splice(@a, -1, 1, "r5");         # shorter
check_contents("rec0blahrec1blahrec4blahr5blah");
splice(@a, -1, 1);               # removal
check_contents("rec0blahrec1blahrec4blah");
splice(@a, -1, 0);               # no-op  
check_contents("rec0blahrec1blahrec4blah");
splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check_contents("rec0blahrec1blahr7blahrec8blahrec4blah");
splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec0blahrec1blahr7blahrec8blahrec7blahrecord8blahrec9blah");

splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check_contents("rec0blahrec1blahr7blahrec8blahrecord9blahrec10blah");
splice(@a, -4, 3);               # delete more than one
check_contents("rec0blahrec1blahrec10blah");

# (83-84) scrub it all out
splice(@a, 0, 3);
check_contents("");

# (85-86) put some back in
splice(@a, 0, 0, "rec0", "rec1");
check_contents("rec0blahrec1blah");

# (87-88) what if we remove too many records?
splice(@a, 0, 17);
check_contents("");

# (89-92) In the past, splicing past the end was not correctly detected
# (0.14)
splice(@a, 89, 3);
check_contents("");
splice(@a, @a, 3);
check_contents("");

# (93-96) Also we did not emulate splice's freaky behavior when inserting
# past the end of the array (1.14)
splice(@a, 89, 0, "I", "like", "pie");
check_contents("Iblahlikeblahpieblah");
splice(@a, 89, 0, "pie pie pie");
check_contents("Iblahlikeblahpieblahpie pie pieblah");

# (97) Splicing with too large a negative number should be fatal
# This test ignored because it causes 5.6.1 and 5.7.3 to dump core
# It also garbles the stack under 5.005_03 (20020401)
# NOT MY FAULT
if ($] > 5.007003) {
  eval { splice(@a, -7, 0) };
  print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/
      ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n";
} else { 
  print "ok $N \# skipped (versions through 5.7.3 dump core here.)\n";
}
$N++;

# (98-101) Test default arguments
splice @a, 0, 0, (0..11);
splice @a, 4;
check_contents("0blah1blah2blah3blah");
splice @a;
check_contents("");


sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

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 {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 14_lock.t ---
#!/usr/bin/perl
#
# Check flock() feature
#
# This isn't a real test; it just checks to make sure we can call the method.
# It doesn't even check to make sure that the default behavior
# (LOCK_EX) is occurring.  This is because I don't know how to write a good
# portable test for flocking.  I checked the Perl core distribution,
# and found that Perl doesn't test flock either!

BEGIN {
  eval { flock STDOUT, 0 };
  if ($@ && $@ =~ /unimplemented/) {
    print "1..0\n";
    exit;
  }
}

use Fcntl ':flock';             # This works at least back to 5.004_04

my $file = "tf$$.txt";
my ($o, $n);
my @a;

print "1..4\n";

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

# 2-4  Who the heck knows?
open F, "> $file" or die $!;
close F;
$o = tie @a, 'Tie::File', $file, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

print $o->flock() ? "ok $N\n" : "not ok $N\n";
$N++;

print $o->flock(LOCK_UN) ? "ok $N\n" : "not ok $N\n";
$N++;


END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 41_heap.t ---
#!/usr/bin/perl
#
# Unit tests for heap implementation
#
# Test the following methods:
# new
# is_empty
# empty
# insert
# remove
# popheap
# promote
# lookup
# set_val
# rekey
# expire_order


# Finish these later.

# They're nonurgent because the important heap stuff is extensively
# tested by tests 19, 20, 24, 30, 32, 33, and 40, as well as by pretty
# much everything else.
print "1..1\n";


my ($N, @R, $Q, $ar) = (1);

use Tie::File;
print "ok $N\n";
$N++;
exit;

__END__

my @HEAP_MOVE;
sub Fake::Cache::_heap_move { push @HEAP_MOVE, @_ }

my $h = Tie::File::Heap->new(bless [] => 'Fake::Cache');
print "ok $N\n";
$N++;

# (3) Are all the methods there?
{
  my $good = 1;
  for my $meth (qw(new is_empty empty lookup insert remove popheap
                   promote set_val rekey expire_order)) {
    unless ($h->can($meth)) {
      print STDERR "# Method '$meth' is missing.\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}

# (4) Straight insert and removal FIFO test
$ar = 'a0';
for (1..10) {
  $h->insert($_, $ar++);
}
for (1..10) {
  push @R, $h->popheap;
}
$iota = iota('a',9);
print "@R" eq $iota
  ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
$N++;

# (5) Remove from empty heap
$n = $h->popheap;
print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
$N++;

# (6) Interleaved insert and removal
$Q = 0;
@R = ();
for my $i (1..4) {
  for my $j (1..$i) {
    $h->insert($Q, "b$Q");
    $Q++;
  }
  for my $j (1..$i) {
    push @R, $h->popheap;
  }
}
$iota = iota('b', 9);
print "@R" eq $iota ? "ok $N\n" : "not ok $N \# expected ($iota), got (@R)\n";
$N++;

# (7) It should be empty now
print $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;

# (8) Insert and delete
$Q = 1;
for (1..10) {
  $h->insert($_, "c$Q");
  $Q++;
}
for (2, 4, 6, 8, 10) {
  $h->remove($_);
}
@R = ();
push @R, $n while defined ($n = $h->popheap);
print "@R" eq "c1 c3 c5 c7 c9" ? 
  "ok $N\n" : "not ok $N \# expected (c1 c3 c5 c7 c9), got (@R)\n";
$N++;

# (9) Interleaved insert and delete
$Q = 1; my $QQ = 1;
@R = ();
for my $i (1..4) {
  for my $j (1..$i) {
    $h->insert($Q, "d$Q");
    $Q++;
  }
  for my $j (1..$i) {
    $h->remove($QQ) if $QQ % 2 == 0;
    $QQ++;
  }
}
push @R, $n while defined ($n = $h->popheap);
print "@R" eq "d1 d3 d5 d7 d9" ? 
  "ok $N\n" : "not ok $N \# expected (d1 d3 d5 d7 d9), got (@R)\n";
$N++;

# (10) Promote
$Q = 1;
for (1..10) {
  $h->insert($_, "e$Q");
  $Q++;
}
for (2, 4, 6, 8, 10) {
  $h->promote($_);
}
@R = ();
push @R, $n while defined ($n = $h->popheap);
print "@R" eq "e1 e3 e5 e7 e9 e2 e4 e6 e8 e10" ? 
  "ok $N\n" : 
  "not ok $N \# expected (e1 e3 e5 e7 e9 e2 e4 e6 e8 e10), got (@R)\n";
$N++;

# (11-15) Lookup
$Q = 1;
for (1..10) {
  $h->insert($_, "f$Q");
  $Q++;
}
for (2, 4, 6, 4, 8) {
  my $r = $h->lookup($_);
  print $r eq "f$_" ? "ok $N\n" : "not ok $N \# expected f$_, got $r\n";
  $N++;
}

# (16) It shouldn't be empty
print ! $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;

# (17) Lookup should have promoted the looked-up records
@R = ();
push @R, $n while defined ($n = $h->popheap);
print "@R" eq "f1 f3 f5 f7 f9 f10 f2 f6 f4 f8" ?
  "ok $N\n" : 
  "not ok $N \# expected (f1 f3 f5 f7 f9 f10 f2 f6 f4 f8), got (@R)\n";
$N++;

# (18-19) Typical 'rekey' operation
$Q = 1;
for (1..10) {
  $h->insert($_, "g$Q");
  $Q++;
}

$h->rekey([6,7,8,9,10], [8,9,10,11,12]);
my %x = qw(1 g1 2 g2  3 g3  4 g4  5 g5
           8 g6 9 g7 10 g8 11 g9 12 g10);
{
  my $good = 1;
  for my $k (keys %x) {
    my $v = $h->lookup($k);
    $v = "UNDEF" unless defined $v;
    unless ($v eq $x{$k}) {
      print "# looked up $k, got $v, expected $x{$k}\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}
{
  my $good = 1;
  for my $k (6, 7) {
    my $v = $h->lookup($k);
    if (defined $v) {
      print "# looked up $k, got $v, should have been undef\n";
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N\n";
  $N++;
}

# (20) keys
@R = sort { $a <=> $b } $h->keys;
print "@R" eq "1 2 3 4 5 8 9 10 11 12" ?
  "ok $N\n" : 
  "not ok $N \# expected (1 2 3 4 5 8 9 10 11 12) got (@R)\n";
$N++;

# (21) update
for (1..5, 8..12) {
  $h->update($_, "h$_");
}
@R = ();
for (sort { $a <=> $b } $h->keys) {
  push @R, $h->lookup($_);
}
print "@R" eq "h1 h2 h3 h4 h5 h8 h9 h10 h11 h12" ?
  "ok $N\n" : 
  "not ok $N \# expected (h1 h2 h3 h4 h5 h8 h9 h10 h11 h12) got (@R)\n";
$N++;

# (22-23) bytes
my $B;
$B = $h->bytes;
print $B == 23 ? "ok $N\n" : "not ok $N \# expected 23, got $B\n";
$N++;
$h->update('12', "yobgorgle");
$B = $h->bytes;
print $B == 29 ? "ok $N\n" : "not ok $N \# expected 29, got $B\n";
$N++;

# (24-25) empty
$h->empty;
print $h->is_empty ? "ok $N\n" : "not ok $N\n";
$N++;
$n = $h->popheap;
print ! defined $n ? "ok $N\n" : "not ok $N \# expected UNDEF, got $n";
$N++;

# (26) very weak testing of DESTROY
undef $h;
# are we still alive?
print "ok $N\n";
$N++;


sub iota {
  my ($p, $n) = @_;
  my $r;
  my $i = 0;
  while ($i <= $n) {
    $r .= "$p$i ";
    $i++;
  }
  chop $r;
  $r;
}

--- NEW FILE: 28_mtwrite.t ---
#!/usr/bin/perl
#
# Unit tests of _mtwrite function
#
# _mtwrite($self, $d1, $s1, $l1, $d2, $s2, $l2, ...)
#
# 'm' here is for 'multiple'.  This writes data $d1 at position $s1
# over a block of space $l1, moving subsequent data up or down as necessary.

my $file = "tf$$.txt";
$| = 1;

print "1..2252\n";

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

$: = Tie::File::_default_recsep();

# Only these are used for the triple-region tests
@BASE_TRIES = (
               [10, 20, 30], 
               [10, 30, 20], 
               [100, 30, 20],
               [100, 20, 30], 
               [100, 40, 20], 
               [100, 20, 40], 
               [200, 20, 30],
               [200, 30, 20],
               [200, 20, 60],
               [200, 60, 20],
               );

@TRIES = @BASE_TRIES;

$FLEN = 40970;   # Use files of this length
$oldfile = mkrand($FLEN);
print "# MOF tests\n";
# These were generated by 'gentests.pl' to cover all possible cases
# (I hope)
# Legend:
#         x: data is entirely contained within one block
#        x>: data runs from the middle to the end of the block
#        <x: data runs from the start to the middle of the block
#       <x>: data occupies precisely one block
#      x><x: data overlaps one block boundary
#     <x><x: data runs from the start of one block into the middle of the next
#     x><x>: data runs from the middle of one block to the end of the next
#    <x><x>: data occupies two blocks exactly
# <x><x><x>: data occupies three blocks exactly
#         0: data is null
#
# For each possible alignment of the old and new data, we investigate
# up to three situations: old data is shorter, old and new data are the
# same length, and new data is shorter.
#
# try($pos, $old, $new) means to run a test where the area being
# written into starts at position $pos, the area being written into
# has length $old, and and the new data has length $new.
try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try( 8771,   776,     0);  # old=x        , new=0        ; old > new
try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(10489,     0,     0);  # old=0        , new=0        ; old = new

print "# SOF tests\n";
# These tests all take place at the start of the file
try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(    0,     0,     0);  # old=0        , new=0        ; old = new

print "# EOF tests 1\n";
# These tests all take place at the end of the file
$FLEN = 40960;  # Force the file to be exactly 40960 bytes long
$oldfile = mkrand($FLEN);
try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(40960,     0,     0);  # old=0        , new=0        ; old = new

print "# EOF tests 2\n";
# These tests all take place at the end of the file
$FLEN = 42000;  # Force the file to be exactly 42000 bytes long
$oldfile = mkrand($FLEN);
try(41683,   317,   317);  # old=x        , new=x        ; old = new
try(41225,   775,   405);  # old=x        , new=x        ; old > new
try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
try(41500,   500,     0);  # old=x        , new=0        ; old > new
try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
try(42000,     0,     0);  # old=0        , new=0        ; old = new

# Now the REAL tests 
# Make sure mtwrite can properly write sequences of several intervals
# The intervals tested above were accumulated into @TRIES.
# try_all_doubles() tries every possible sensible pair of those intervals.
# try_all_triples() tries every possible sensible group of 
#  tree intervals from the more restrictive set @BASE_TRIES.
$FLEN = 40970;
$oldfile = mkrand($FLEN);
try_all_doubles();
try_all_triples();

sub mkrand {
  my $len = shift;
  srand $len;
  my @c = ('a' .. 'z', 'A' .. 'Z', 0..9, $:);
  my $d = "";
  $d .= $c[rand @c] until length($d) >= $len;
  substr($d, $len) = ""; # chop it off to the proper length
  $d;
}

sub try {
  push @TRIES, [@_] if @_ == 3;

  open F, "> $file" or die "Couldn't open file $file: $!";
  binmode F;
  print F $oldfile;
  close F;
  die "wrong length!" unless -s $file == $FLEN;

  my @mt_args; 
  my $expected = $oldfile;
  { my @a = @_;
    my $c = "a";
    while (@a) {
      my ($s, $len, $newlen) = splice @a, -3;
      my $newdata = $c++ x $newlen;
      substr($expected, $s, $len, $newdata);
      unshift @mt_args, $newdata, $s, $len;
    }
  }

  my $o = tie my @lines, 'Tie::File', $file or die $!;
  my $actual_return = $o->_mtwrite(@mt_args);
  undef $o; untie @lines;

  open F, "< $file" or die "Couldn't open file $file: $!";
  binmode F;
  my $actual;
  { local $/;
    $actual = <F>;
  }
  close F;

  my ($alen, $xlen) = (length $actual, length $expected);
  unless ($alen == $xlen) {
    print "# try(@_) expected file length $xlen, actual $alen!\n";
  }
  print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
  $N++;

#  if (! defined $actual_return && ! defined $expected_return) {
#    print "ok $N\n";
#  } elsif (! defined $actual_return || ! defined $expected_return) {
#    print "not ok $N\n";
#  } else {
#    print $actual_return eq $expected_return ? "ok $N\n" : "not ok $N\n";
#  }
#  $N++;
}

sub try_all_doubles {
  print "# Trying double regions.\n";
  for my $a (@TRIES) {
    next if $a->[0] + $a->[1] >= $FLEN;
    next if $a->[0] + $a->[2] >= $FLEN;
    for my $b (@TRIES) {
      next if $b->[0] + $b->[1] >= $FLEN;
      next if $b->[0] + $b->[2] >= $FLEN;

      next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions
      try(@$a, @$b);
    }
  }
}

sub try_all_triples {
  print "# Trying triple regions.\n";
  for my $a (@BASE_TRIES) {
    next if $a->[0] + $a->[1] >= $FLEN;
    next if $a->[0] + $a->[2] >= $FLEN;
    for my $b (@BASE_TRIES) {
      next if $b->[0] + $b->[1] >= $FLEN;
      next if $b->[0] + $b->[2] >= $FLEN;

      next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions

      for my $c (@BASE_TRIES) {
        next if $c->[0] + $c->[1] >= $FLEN;
        next if $c->[0] + $c->[2] >= $FLEN;

        next if $c->[0] < $b->[0] + $b->[1]; # Overlapping regions
        try(@$a, @$b, @$c);
      }
    }
  }
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  1 while unlink $file;
}


--- NEW FILE: 06_fixrec.t ---
#!/usr/bin/perl

use POSIX 'SEEK_SET';
my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();

print "1..5\n";

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

my $o = tie @a, 'Tie::File', $file, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$a[0] = 'rec0';
check_contents("rec0$:");
$a[1] = "rec1$:";
check_contents("rec0$:rec1$:");
$a[2] = "rec2$:$:";             # should we detect this?
check_contents("rec0$:rec1$:rec2$:$:");

sub check_contents {
  my $x = shift;
  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 = "not ok $N # expected <$x>, got <$a>";
    ctrlfix($msg);
    print "$msg\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 13_size_rs.t ---
#!/usr/bin/perl
#
# Check FETCHSIZE and SETSIZE functions
# PUSH POP SHIFT UNSHIFT
#

use POSIX 'SEEK_SET';

my $file = "tf$$.txt";
my $data = "rec0blahrec1blahrec2blah";
my ($o, $n);

print "1..10\n";

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

# 2-3 FETCHSIZE 0-length file
open F, "> $file" or die $!;
close F;
$o = tie @a, 'Tie::File', $file, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
$n = @a;
print $n == 0 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
$N++;

# Reset everything
undef $o;
untie @a;

# 4-5 FETCHSIZE positive-length file
open F, "> $file" or die $!;
print F $data;
close F;
$o = tie @a, 'Tie::File', $file, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;
$n = @a;
print $n == 3 ? "ok $N\n" : "not ok $N # $n, s/b 0\n";
$N++;

# STORESIZE
# 6 Make it longer:
$#a = 4;
check_contents("${data}blahblah");

# 7 Make it longer again:
$#a = 6;
check_contents("${data}blahblahblahblah");

# 8 Make it shorter:
$#a = 4;
check_contents("${data}blahblah");

# 9 Make it shorter again:
$#a = 2;
check_contents($data);

# 10 Get rid of it completely:
$#a = -1;
check_contents('');


sub check_contents {
  my $x = shift;
  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 {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N\n$msg\n";
  }
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 22_autochomp.t ---
#!/usr/bin/perl

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();

print "1..71\n";

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

my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# 3-5 create
$a[0] = 'rec0';
check_contents("rec0");

# 6-11 append
$a[1] = 'rec1';
check_contents("rec0", "rec1");
$a[2] = 'rec2';
check_contents("rec0", "rec1", "rec2");

# 12-20 same-length alterations
$a[0] = 'new0';
check_contents("new0", "rec1", "rec2");
$a[1] = 'new1';
check_contents("new0", "new1", "rec2");
$a[2] = 'new2';
check_contents("new0", "new1", "new2");

# 21-35 lengthening alterations
$a[0] = 'long0';
check_contents("long0", "new1", "new2");
$a[1] = 'long1';
check_contents("long0", "long1", "new2");
$a[2] = 'long2';
check_contents("long0", "long1", "long2");
$a[1] = 'longer1';
check_contents("long0", "longer1", "long2");
$a[0] = 'longer0';
check_contents("longer0", "longer1", "long2");

# 36-50 shortening alterations, including truncation
$a[0] = 'short0';
check_contents("short0", "longer1", "long2");
$a[1] = 'short1';
check_contents("short0", "short1", "long2");
$a[2] = 'short2';
check_contents("short0", "short1", "short2");
$a[1] = 'sh1';
check_contents("short0", "sh1", "short2");
$a[0] = 'sh0';
check_contents("sh0", "sh1", "short2");

# (51-56) file with holes
$a[4] = 'rec4';
check_contents("sh0", "sh1", "short2", "", "rec4");
$a[3] = 'rec3';
check_contents("sh0", "sh1", "short2", "rec3", "rec4");

# (57-59) zero out file
@a = ();
check_contents();

# (60-62) insert into the middle of an empty file
$a[3] = "rec3";
check_contents("", "", "", "rec3");

# (63-68) Test the ->autochomp() method
@a = qw(Gold Frankincense Myrrh);
my $ac;
$ac = $o->autochomp();
expect($ac);
# See if that accidentally changed it
$ac = $o->autochomp();
expect($ac);
# Now clear it
$ac = $o->autochomp(0);
expect($ac);
expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
# Now set it again
$ac = $o->autochomp(1);
expect(!$ac);
expect(join("-", @a), "Gold-Frankincense-Myrrh");

# (69) Does 'splice' work correctly with autochomp?
my @sr;
@sr = splice @a, 0, 2;
expect(join("-", @sr), "Gold-Frankincense");

# (70-71) Didn't you forget that fetch may return an unchomped cached record?
$a1 = $a[0];                    # populate cache
$a2 = $a[0];
expect($a1, "Myrrh");
expect($a2, "Myrrh");
# Actually no, you didn't---_fetch might return such a record, but 
# the chomping is done by FETCH.

use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq $c[$_]) {
      $msg = "expected <$c[$_]>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub expect {
  if (@_ == 1) {
    print $_[0] ? "ok $N\n" : "not ok $N\n";
  } elsif (@_ == 2) {
    my ($a, $x) = @_;
    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
    elsif (  defined($a) && ! defined($x)) { 
      ctrlfix(my $msg = "expected UNDEF, got <$a>");
      print "not ok $N \# $msg\n";
    }
    elsif (! defined($a) &&   defined($x)) { 
      ctrlfix(my $msg = "expected <$x>, got UNDEF");
      print "not ok $N \# $msg\n";
    } elsif ($a eq $x) { print "ok $N\n" }
    else {
      ctrlfix(my $msg = "expected <$x>, got <$a>");
      print "not ok $N \# $msg\n";
    }
  } else {
    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 02_fetchsize.t ---
#!/usr/bin/perl

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec1$:rec2$:rec3$:";

print "1..6\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;


my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};

my $n;

# 3  test array element count
$n = @a;
print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n";
$N++;

# 4 same thing again   
$n = @a;
print $n == 3 ? "ok $N\n" : "not ok $N # n=$n\n";
$N++;

# 5  test $#a notation
$n = $#a;
print $n == 2 ? "ok $N\n" : "not ok $N # n=$n\n";
$N++;

# 6  test looping over array elements
my $q;
for (@a) { $q .= $_ }
print $q eq $data ? "ok $N\n" : "not ok $N # n=$n\n";
$N++;

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 07_rv_splice.t ---
#!/usr/bin/perl
#
# Check SPLICE function's return value
# (04_splice.t checks its effect on the file)
#


my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";

print "1..56\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

init_file($data);

my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# (3-12) splicing at the beginning
@r = splice(@a, 0, 0, "rec4");
check_result();
@r = splice(@a, 0, 1, "rec5");       # same length
check_result("rec4");
@r = splice(@a, 0, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, 0, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 0, 1);               # removal
check_result("r5");
@r = splice(@a, 0, 0);               # no-op
check_result();
@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 0, 2);               # delete more than one
check_result('record9', 'rec10');


# (13-22) splicing in the middle
@r = splice(@a, 1, 0, "rec4");
check_result();
@r = splice(@a, 1, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 1, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 1, 1);               # removal
check_result("r5");
@r = splice(@a, 1, 0);               # no-op
check_result();
@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 1, 2);               # delete more than one
check_result('record9','rec10');

# (23-32) splicing at the end
@r = splice(@a, 3, 0, "rec4");
check_result();
@r = splice(@a, 3, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 3, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 3, 1, "r5");         # shorter
check_result('record5');
@r = splice(@a, 3, 1);               # removal
check_result('r5');
@r = splice(@a, 3, 0);               # no-op
check_result();
@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 3, 2);               # delete more than one
check_result('record9', 'rec10');

# (33-42) splicing with negative subscript
@r = splice(@a, -1, 0, "rec4");
check_result();
@r = splice(@a, -1, 1, "rec5");       # same length
check_result('rec2');
@r = splice(@a, -1, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, -1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, -1, 1);               # removal
check_result("r5");
@r = splice(@a, -1, 0);               # no-op  
check_result();
@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('rec4');

@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, -4, 3);               # delete more than one
check_result('r7', 'rec8', 'record9');

# (43) scrub it all out
@r = splice(@a, 0, 3);
check_result('rec0', 'rec1', 'rec10');

# (44) put some back in
@r = splice(@a, 0, 0, "rec0", "rec1");
check_result();

# (45) what if we remove too many records?
@r = splice(@a, 0, 17);
check_result('rec0', 'rec1');

# (46-48) Now check the scalar context return
splice(@a, 0, 0, qw(I like pie));
my $r;
$r = splice(@a, 0, 0);
print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef, was <$r>\n";
$N++;

$r = splice(@a, 2, 1);
print $r eq "pie$:" ? "ok $N\n" : "not ok $N \# return should have been 'pie\\n', was <$r>\n";
$N++;

$r = splice(@a, 0, 2);
print $r eq "like$:" ? "ok $N\n" : "not ok $N \# return should have been 'like\\n', was <$r>\n";
$N++;

# (49-50) Test default arguments
splice @a, 0, 0, (0..11);
@r = splice @a, 4;
check_result(4..11);
@r = splice @a;
check_result(0..3);

# (51-56) splice with negative length was treated wrong
# 20020402 Reported by Juerd Waalboer
@a = (0..8) ;
@r = splice @a, 0, -3;
check_result(0..5);
@a = (0..8) ;
@r = splice @a, 1, -3;
check_result(1..5);
@a = (0..8) ;
@r = splice @a, 7, -3;
check_result();
@a = (0..2) ;
@r = splice @a, 0, -3;
check_result();
@a = (0..2) ;
@r = splice @a, 1, -3;
check_result();
@a = (0..2) ;
@r = splice @a, 7, -3;
check_result();

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

# actual results are in @r.
# expected results are in @_
sub check_result {
  my @x = @_;
  s/$:$// for @r;
  my $good = 1;
  $good = 0 unless @r == @x;
  for my $i (0 .. $#r) {
    $good = 0 unless $r[$i] eq $x[$i];
  }
  print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
  $N++;
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 19_cache.t ---
#!/usr/bin/perl
#
# Tests for various caching errors
#

$|=1;
my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = join $:, "rec0" .. "rec9", "";
my $V = $ENV{INTEGRITY};        # Verbose integrity checking?

print "1..55\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;

my $o = tie @a, 'Tie::File', $file;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (3) Through 0.18, this 'splice' call would corrupt the cache.
my @z = @a;                     # force cache to contain all ten records
splice @a, 0, 0, "x";
print $o->_check_integrity($file, $V) ? "ok $N\n" : "not ok $N\n";
$N++;

# Here we redo *all* the splice tests, with populate()
# calls before each one, to make sure that splice() does not botch the cache.

# (4-14) splicing at the beginning
check();
splice(@a, 0, 0, "rec4");
check();
splice(@a, 0, 1, "rec5");       # same length
check();
splice(@a, 0, 1, "record5");    # longer
check();
splice(@a, 0, 1, "r5");         # shorter
check();
splice(@a, 0, 1);               # removal
check();
splice(@a, 0, 0);               # no-op
check();

splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 0, 2);               # delete more than one
check();


# (15-24) splicing in the middle
splice(@a, 1, 0, "rec4");
check();
splice(@a, 1, 1, "rec5");       # same length
check();
splice(@a, 1, 1, "record5");    # longer
check();
splice(@a, 1, 1, "r5");         # shorter
check();
splice(@a, 1, 1);               # removal
check();
splice(@a, 1, 0);               # no-op
check();

splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 1, 2);               # delete more than one
check();

# (25-34) splicing at the end
splice(@a, 3, 0, "rec4");
check();
splice(@a, 3, 1, "rec5");       # same length
check();
splice(@a, 3, 1, "record5");    # longer
check();
splice(@a, 3, 1, "r5");         # shorter
check();
splice(@a, 3, 1);               # removal
check();
splice(@a, 3, 0);               # no-op
check();

splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 3, 2);               # delete more than one
check();

# (35-44) splicing with negative subscript
splice(@a, -1, 0, "rec4");
check();
splice(@a, -1, 1, "rec5");       # same length
check();
splice(@a, -1, 1, "record5");    # longer
check();
splice(@a, -1, 1, "r5");         # shorter
check();
splice(@a, -1, 1);               # removal
check();
splice(@a, -1, 0);               # no-op  
check();

splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, -4, 3);               # delete more than one
check();

# (45) scrub it all out
splice(@a, 0, 3);
check();

# (46) put some back in
splice(@a, 0, 0, "rec0", "rec1");
check();

# (47) what if we remove too many records?
splice(@a, 0, 17);
check();

# (48-49) In the past, splicing past the end was not correctly detected
# (1.14)
splice(@a, 89, 3);
check();
splice(@a, @a, 3);
check();

# (50-51) Also we did not emulate splice's freaky behavior when inserting
# past the end of the array (1.14)
splice(@a, 89, 0, "I", "like", "pie");
check();
splice(@a, 89, 0, "pie pie pie");
check();

# (52-54) Test default arguments
splice @a, 0, 0, (0..11);
check();
splice @a, 4;
check();
splice @a;
check();
    
# (55) This was broken on 20030507 when you moved the cache management
# stuff out of _oadjust back into _splice without also putting it back 
# into _store.
@a = (0..11);
check();

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

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


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

sub repopulate {
  $o->{cache}->empty;
  my @z = @a;                   # refill the cache with correct data
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}




--- NEW FILE: 20_cache_full.t ---
#!/usr/bin/perl
#
# Tests for various caching errors
#

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = join $:, "record0" .. "record9", "";
my $V = $ENV{INTEGRITY};        # Verbose integrity checking?

print "1..111\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;

# Limit cache size to 30 bytes 
my $MAX = 30;
#  -- that's enough space for 3 records, but not 4, on both \n and \r\n systems
my $o = tie @a, 'Tie::File', $file, memory => $MAX, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (3-5) Let's see if data was properly expired from the cache
my @z = @a;                     # force cache to contain all ten records
# It should now contain only the *last* three records, 7, 8, and 9
{
  my $x = "7 8 9";
  my $a = join " ", sort $o->{cache}->ckeys;
  if ($a eq $x) { print "ok $N\n" }
  else { print "not ok $N # cache keys were <$a>; expected <$x>\n" }
  $N++;
}
check();

# Here we redo *all* the splice tests, with populate()
# calls before each one, to make sure that splice() does not botch the cache.

# (6-25) splicing at the beginning
splice(@a, 0, 0, "rec4");
check();
splice(@a, 0, 1, "rec5");       # same length
check();
splice(@a, 0, 1, "record5");    # longer
check();
splice(@a, 0, 1, "r5");         # shorter
check();
splice(@a, 0, 1);               # removal
check();
splice(@a, 0, 0);               # no-op
check();

splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 0, 2);               # delete more than one
check();


# (26-45) splicing in the middle
splice(@a, 1, 0, "rec4");
check();
splice(@a, 1, 1, "rec5");       # same length
check();
splice(@a, 1, 1, "record5");    # longer
check();
splice(@a, 1, 1, "r5");         # shorter
check();
splice(@a, 1, 1);               # removal
check();
splice(@a, 1, 0);               # no-op
check();

splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 1, 2);               # delete more than one
check();

# (46-65) splicing at the end
splice(@a, 3, 0, "rec4");
check();
splice(@a, 3, 1, "rec5");       # same length
check();
splice(@a, 3, 1, "record5");    # longer
check();
splice(@a, 3, 1, "r5");         # shorter
check();
splice(@a, 3, 1);               # removal
check();
splice(@a, 3, 0);               # no-op
check();

splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, 3, 2);               # delete more than one
check();

# (66-85) splicing with negative subscript
splice(@a, -1, 0, "rec4");
check();
splice(@a, -1, 1, "rec5");       # same length
check();
splice(@a, -1, 1, "record5");    # longer
check();
splice(@a, -1, 1, "r5");         # shorter
check();
splice(@a, -1, 1);               # removal
check();
splice(@a, -1, 0);               # no-op  
check();

splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check();
splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check();
splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check();
splice(@a, -4, 3);               # delete more than one
check();

# (86-87) scrub it all out
splice(@a, 0, 3);
check();

# (88-89) put some back in
splice(@a, 0, 0, "rec0", "rec1");
check();

# (90-91) what if we remove too many records?
splice(@a, 0, 17);
check();

# (92-95) In the past, splicing past the end was not correctly detected
# (1.14)
splice(@a, 89, 3);
check();
splice(@a, @a, 3);
check();

# (96-99) Also we did not emulate splice's freaky behavior when inserting
# past the end of the array (1.14)
splice(@a, 89, 0, "I", "like", "pie");
check();
splice(@a, 89, 0, "pie pie pie");
check();

# (100-105) Test default arguments
splice @a, 0, 0, (0..11);
check();
splice @a, 4;
check();
splice @a;
check();

# (106-111) One last set of tests.  I don't know what state the cache
# is in now.  But if I read any three records, those three records are
# what should be in the cache, and nothing else.
@a = "record0" .. "record9";
check(); # In 0.18 #107 fails here--STORE was not flushing the cache when
         # replacing an old cached record with a longer one
for (5, 6, 1) { my $z = $a[$_] }
{
  my $x = "5 6 1";
  my $a = join " ", $o->{cache}->_produce_lru;
  if ($a eq $x) { print "ok $N\n" }
  else { print "not ok $N # LRU was <$a>; expected <$x>\n" }
  $N++;
  $x = "1 5 6";
  $a = join " ", sort $o->{cache}->ckeys;
  if ($a eq $x) { print "ok $N\n" }
  else { print "not ok $N # cache keys were <$a>; expected <$x>\n" }
  $N++;
}
check();


sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

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

  my $b = $o->{cache}->bytes;
  print $b <= $MAX 
    ? "ok $N\n" 
    : "not ok $N # $b bytes cached, should be <= $MAX\n";
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}




--- NEW FILE: 18_rs_fixrec.t ---
#!/usr/bin/perl

use POSIX 'SEEK_SET';
my $file = "tf$$.txt";
$/ = "blah";

print "1..5\n";

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

my $o = tie @a, 'Tie::File', $file, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$a[0] = 'rec0';
check_contents("rec0blah");
$a[1] = "rec1blah";
check_contents("rec0blahrec1blah");
$a[2] = "rec2blahblah";             # should we detect this?
check_contents("rec0blahrec1blahrec2blahblah");

sub check_contents {
  my $x = shift;
  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 = "not ok $N # expected <$x>, got <$a>";
    ctrlfix($msg);
    print "$msg\n";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 17_misc_meth.t ---
#!/usr/bin/perl
#
# Check miscellaneous tied-array interface methods
# EXTEND, CLEAR, DELETE, EXISTS
#

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
1 while unlink $file;

print "1..35\n";

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

my $o = tie @a, 'Tie::File', $file, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (3-8) EXTEND
$o->EXTEND(3);
check_contents("$:$:$:");
$o->EXTEND(4);
check_contents("$:$:$:$:");
$o->EXTEND(3);
check_contents("$:$:$:$:");

# (9-10) CLEAR
@a = ();
check_contents("");

# (11-20) EXISTS
if ($] >= 5.006) {
  eval << 'TESTS';
print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
$N++;
$a[0] = "I like pie.";
print exists $a[0] ? "ok $N\n" : "not ok $N\n";
$N++;
print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
$N++;
$a[2] = "GIVE ME PIE";
print exists $a[0] ? "ok $N\n" : "not ok $N\n";
$N++;
# exists $a[1] is not defined by this module under these circumstances
print exists $a[1] ? "ok $N\n" : "ok $N\n";
$N++;
print exists $a[2] ? "ok $N\n" : "not ok $N\n";
$N++;
print exists $a[-1] ? "ok $N\n" : "not ok $N\n";
$N++;
print exists $a[-2] ? "ok $N\n" : "not ok $N\n";
$N++;
print exists $a[-3] ? "ok $N\n" : "not ok $N\n";
$N++;
print !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
$N++;
TESTS
  } else {                      # perl 5.005 doesn't have exists $array[1]
    for (11..20) {
      print "ok $_ \# skipped (no exists for arrays)\n";
          $N++;
    }
  }

my $del;

# (21-35) DELETE
if ($] >= 5.006) {
  eval << 'TESTS';
$del = delete $a[0];
check_contents("$:$:GIVE ME PIE$:");
# 20020317 Through 0.20, the 'delete' function returned the wrong values.
expect($del, "I like pie.");
$del = delete $a[2];
check_contents("$:$:");
expect($del, "GIVE ME PIE");
$del = delete $a[0];
check_contents("$:$:");
expect($del, "");
$del = delete $a[1];
check_contents("$:");
expect($del, "");

# 20020317 Through 0.20, we had a bug where deleting an element past the 
# end of the array would actually extend the array to that length.
$del = delete $a[4];
check_contents("$:");
expect($del, undef);



TESTS
  } else {                      # perl 5.005 doesn't have delete $array[1]
    for (21..35) {
      print "ok $_ \# skipped (no delete for arrays)\n";
          $N++;
    }
  }

use POSIX 'SEEK_SET';
sub check_contents {
  my $x = shift;
  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 {
    ctrlfix(my $msg = "# expected <$x>, got <$a>");
    print "not ok $N # $msg\n";
  }
  $N++;
  print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
  $N++;
}

sub expect {
  if (@_ == 1) {
    print $_[0] ? "ok $N\n" : "not ok $N\n";
  } elsif (@_ == 2) {
    my ($a, $x) = @_;
    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
    elsif (  defined($a) && ! defined($x)) { 
      ctrlfix(my $msg = "expected UNDEF, got <$a>");
      print "not ok $N \# $msg\n";
    }
    elsif (! defined($a) &&   defined($x)) { 
      ctrlfix(my $msg = "expected <$x>, got UNDEF");
      print "not ok $N \# $msg\n";
    } elsif ($a eq $x) { print "ok $N\n" }
    else {
      ctrlfix(my $msg = "expected <$x>, got <$a>");
      print "not ok $N \# $msg\n";
    }
  } else {
    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
  }
  $N++;
}

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}



--- NEW FILE: 00_version.t ---
#!/usr/bin/perl

print "1..1\n";

my $testversion = "0.97";
use Tie::File;

if ($Tie::File::VERSION != $testversion) {
  print STDERR "

*** WHOA THERE!!! ***

You seem to be running version $Tie::File::VERSION of the module
against version $testversion of the test suite!

None of the other test results will be reliable.
";
  exit 1;
}

print "ok 1\n";


--- NEW FILE: 29a_upcopy.t ---
#!/usr/bin/perl
#
# Unit tests of _upcopy function
#
# _upcopy($self, $source, $dest, $len)
#
# Take a block of data of leength $len at $source and copy it
# to $dest, which must be <= $source but which need not be <= $source - $len
# (That is, this will only copy a block to a position earlier in the file,
# but the source and destination regions may overlap.)


my $file = "tf$$.txt";

print "1..55\n";

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

$: = Tie::File::_default_recsep();

my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);

$FLEN = 40970;  # 2410 records of 17 chars each

# (2-7) Trivial non-moves at start of file
try(0, 0, 0);
try(0, 0, 10);
try(0, 0, 100);
try(0, 0, 1000);
try(0, 0, 10000);
try(0, 0, 20000);

# (8-13) Trivial non-moves in middle of file
try(100, 100, 0);
try(100, 100, 10);
try(100, 100, 100);
try(100, 100, 1000);
try(100, 100, 10000);
try(100, 100, 20000);

# (14) Trivial non-move at end of file
try($FLEN, $FLEN, 0);

# (15-17) Trivial non-move of tail of file
try(0, 0, undef);
try(100, 100, undef);
try($FLEN, $FLEN, undef);

# (18-24) Moves to start of file
try(100, 0, 0);
try(100, 0, 10);
try(100, 0, 100);
try(100, 0, 1000);
try(100, 0, 10000);
try(100, 0, 20000);
try(100, 0, undef);

# (25-31) Moves in middle of file
try(200, 100, 0);
try(200, 100, 10);
try(200, 100, 100);
try(200, 100, 1000);
try(200, 100, 10000);
try(200, 100, 20000);
try(200, 100, undef);

# (32-43) Moves from end of file
try($FLEN, 10000, 0);
try($FLEN-10, 10000, 10);
try($FLEN-100, 10000, 100);
try($FLEN-1000, 200, 1000);
try($FLEN-10000, 200, 10000);
try($FLEN-20000, 200, 20000);
try($FLEN, 10000, undef);
try($FLEN-10, 10000, undef);
try($FLEN-100, 10000, undef);
try($FLEN-1000, 200, undef);
try($FLEN-10000, 200, undef);
try($FLEN-20000, 200, undef);

$FLEN = 40960;

# (44-55) Moves from end of file when file ends on a block boundary
try($FLEN, 10000, 0);
try($FLEN-10, 10000, 10);
try($FLEN-100, 10000, 100);
try($FLEN-1000, 200, 1000);
try($FLEN-10000, 200, 10000);
try($FLEN-20000, 200, 20000);
try($FLEN, 10000, undef);
try($FLEN-10, 10000, undef);
try($FLEN-100, 10000, undef);
try($FLEN-1000, 200, undef);
try($FLEN-10000, 200, undef);
try($FLEN-20000, 200, undef);

sub try {
  my ($src, $dst, $len) = @_;
  open F, "> $file" or die "Couldn't open file $file: $!";
  binmode F;

  # The record has exactly 17 characters.  This will help ensure that
  # even if _upcopy screws up, the data doesn't coincidentally
  # look good because the remainder accidentally lines up.
  my $d = substr("0123456789abcdef$:", -17);
  my $recs = defined($FLEN) ?
    int($FLEN/length($d))+1 : # enough to make up at least $FLEN
    int(8192*5/length($d))+1; # at least 5 blocks' worth
  my $oldfile = $d x $recs;
  my $flen = defined($FLEN) ? $FLEN : $recs * 17;
  substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
  print F $oldfile;
  close F;

  die "wrong length!" unless -s $file == $flen;

  # If len is specified, use that.  If it's undef,
  # then behave *as if* we had specified the whole rest of the file
  my $expected = $oldfile;
  if (defined $len) {
    substr($expected, $dst, $len) = substr($expected, $src, $len);
  } else {
    substr($expected, $dst) = substr($expected, $src);
  }

  my $o = tie my @lines, 'Tie::File', $file or die $!;
  local $SIG{ALRM} = sub { die "Alarm clock" };
  my $a_retval = eval { alarm(5) unless $^P; $o->_upcopy($src, $dst, $len) };
  my $err = $@;
  undef $o; untie @lines; alarm(0);
  if ($err) {
    if ($err =~ /^Alarm clock/) {
      print "# Timeout\n";
      print "not ok $N\n"; $N++;
      return;
    } else {
      $@ = $err;
      die;
    }
  }

  open F, "< $file" or die "Couldn't open file $file: $!";
  binmode F;
  my $actual;
  { local $/;
    $actual = <F>;
  }
  close F;

  my ($alen, $xlen) = (length $actual, length $expected);
  unless ($alen == $xlen) {
    print "# try(@_) expected file length $xlen, actual $alen!\n";
  }
  print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
  $N++;
}



use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq "$c[$_]$:") {
      $msg = "expected <$c[$_]$:>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 29_downcopy.t ---
#!/usr/bin/perl
#
# Unit tests of _downcopy function
#
# _downcopy($self, $data, $pos, $len)
# Write $data into a block of length $len at position $pos,
# moving everything in the block forwards to make room.
# Instead of writing the last length($data) bytes from the block
# (because there isn't room for them any longer) return them.
#
#

my $file = "tf$$.txt";

print "1..718\n";

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

$: = Tie::File::_default_recsep();

my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
print "ok $N\n"; $N++;

# (3-144) These were generated by 'gentests.pl' to cover all possible cases
# (I hope)
# Legend:
#         x: data is entirely contained within one block
#        x>: data runs from the middle to the end of the block
#        <x: data runs from the start to the middle of the block
#       <x>: data occupies precisely one block
#      x><x: data overlaps one block boundary
#     <x><x: data runs from the start of one block into the middle of the next
#     x><x>: data runs from the middle of one block to the end of the next
#    <x><x>: data occupies two blocks exactly
# <x><x><x>: data occupies three blocks exactly
#         0: data is null
#
# For each possible alignment of the old and new data, we investigate
# up to three situations: old data is shorter, old and new data are the
# same length, and new data is shorter.
#
# try($pos, $old, $new) means to run a test where the data starts at 
# position $pos, the old data has length $old,
# and the new data has length $new.
try( 9659,  6635,  6691);  # old=x        , new=x        ; old < new
try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
try( 8394,     0,  5742);  # old=0        , new=x        ; old < new
try( 8192,  2819,  6738);  # old=<x       , new=<x       ; old < new
try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
try( 8192,     0,  6870);  # old=0        , new=<x       ; old < new
try( 8478,  6259,  7906);  # old=x        , new=x>       ; old < new
try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
try( 9759,     0,  6625);  # old=0        , new=x>       ; old < new
try( 8525,  2081,  8534);  # old=x        , new=x><x     ; old < new
try(15550,   834,  1428);  # old=x>       , new=x><x     ; old < new
try(14966,  1668,  3479);  # old=x><x     , new=x><x     ; old < new
try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
try(12602,     0,  8354);  # old=0        , new=x><x     ; old < new
try( 8192,  2767,  8192);  # old=<x       , new=<x>      ; old < new
try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try( 8192,     0,  8192);  # old=0        , new=<x>      ; old < new
try( 8192,  6532, 10882);  # old=<x       , new=<x><x    ; old < new
try( 8192,  8192, 16044);  # old=<x>      , new=<x><x    ; old < new
try( 8192,  9555, 11020);  # old=<x><x    , new=<x><x    ; old < new
try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
try( 8192,     0, 12488);  # old=0        , new=<x><x    ; old < new
try( 8222,  6385, 16354);  # old=x        , new=x><x>    ; old < new
try(13500,  2884, 11076);  # old=x>       , new=x><x>    ; old < new
try(14069,  4334, 10507);  # old=x><x     , new=x><x>    ; old < new
try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
try(10469,     0, 14107);  # old=0        , new=x><x>    ; old < new
try( 8192,  4181, 16384);  # old=<x       , new=<x><x>   ; old < new
try( 8192,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try( 8192, 12087, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try( 8192,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try( 8192,  4968, 24576);  # old=<x       , new=<x><x><x>; old < new
try( 8192,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try( 8192, 14163, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try( 8192, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try( 8192,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try( 8771,   776,     0);  # old=x        , new=0        ; old > new
try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(10489,     0,     0);  # old=0        , new=0        ; old = new

# (142-223)
# These tests all take place at the start of the file
try(    0,   771,  1593);  # old=<x       , new=<x       ; old < new
try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
try(    0,     0,  1317);  # old=0        , new=<x       ; old < new
try(    0,  5609,  8192);  # old=<x       , new=<x>      ; old < new
try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(    0,     0,  8192);  # old=0        , new=<x>      ; old < new
try(    0,  6265,  9991);  # old=<x       , new=<x><x    ; old < new
try(    0,  8192, 16119);  # old=<x>      , new=<x><x    ; old < new
try(    0, 10218, 11888);  # old=<x><x    , new=<x><x    ; old < new
try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
try(    0,     0, 10881);  # old=0        , new=<x><x    ; old < new
try(    0,  6448, 16384);  # old=<x       , new=<x><x>   ; old < new
try(    0,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try(    0, 15082, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(    0,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(    0,  2421, 24576);  # old=<x       , new=<x><x><x>; old < new
try(    0,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try(    0, 11655, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try(    0, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(    0,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(    0,     0,     0);  # old=0        , new=0        ; old = new

# (224-277)
# These tests all take place at the end of the file
$FLEN = 40960;  # Force the file to be exactly 40960 bytes long
try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
try(40960,     0,  2779);  # old=0        , new=<x       ; old < new
try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(40960,     0,  8192);  # old=0        , new=<x>      ; old < new
try(32768,  8192, 10724);  # old=<x>      , new=<x><x    ; old < new
try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
try(40960,     0, 11752);  # old=0        , new=<x><x    ; old < new
try(32768,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(40960,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(32768,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try(24576, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(40960,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(40960,     0,     0);  # old=0        , new=0        ; old = new

# (278-357)
# These tests all take place at the end of the file
$FLEN = 42000;  # Force the file to be exactly 42000 bytes long
try(41275,   725,  4059);  # old=x        , new=x        ; old < new
try(41683,   317,   317);  # old=x        , new=x        ; old = new
try(41225,   775,   405);  # old=x        , new=x        ; old > new
try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
try(42000,     0,  2434);  # old=0        , new=x        ; old < new
try(40960,  1040,  1608);  # old=<x       , new=<x       ; old < new
try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
try(42000,     0,  6637);  # old=0        , new=<x       ; old < new
try(41022,   978,  8130);  # old=x        , new=x>       ; old < new
try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
try(42000,     0,  7152);  # old=0        , new=x>       ; old < new
try(41613,   387, 10601);  # old=x        , new=x><x     ; old < new
try(38460,  3540,  3938);  # old=x><x     , new=x><x     ; old < new
try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
try(42000,     0,  9189);  # old=0        , new=x><x     ; old < new
try(40960,  1040,  8192);  # old=<x       , new=<x>      ; old < new
try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
try(42000,     0,  8192);  # old=0        , new=<x>      ; old < new
try(40960,  1040, 11778);  # old=<x       , new=<x><x    ; old < new
try(32768,  9232, 13792);  # old=<x><x    , new=<x><x    ; old < new
try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
try(42000,     0,  8578);  # old=0        , new=<x><x    ; old < new
try(41531,   469, 15813);  # old=x        , new=x><x>    ; old < new
try(39618,  2382,  9534);  # old=x><x     , new=x><x>    ; old < new
try(42000,     0, 15344);  # old=0        , new=x><x>    ; old < new
try(40960,  1040, 16384);  # old=<x       , new=<x><x>   ; old < new
try(32768,  9232, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try(42000,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(40960,  1040, 24576);  # old=<x       , new=<x><x><x>; old < new
try(32768,  9232, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try(42000,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(41500,   500,     0);  # old=x        , new=0        ; old > new
try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
try(42000,     0,     0);  # old=0        , new=0        ; old = new

sub try {
  my ($pos, $len, $newlen) = @_;
  open F, "> $file" or die "Couldn't open file $file: $!";
  binmode F;

  # The record has exactly 17 characters.  This will help ensure that
  # even if _downcoopy screws up, the data doesn't coincidentally
  # look good because the remainder accidentally lines up.
  my $d = substr("0123456789abcdef$:", -17);
  my $recs = defined($FLEN) ?
    int($FLEN/length($d))+1 : # enough to make up at least $FLEN
    int(8192*5/length($d))+1; # at least 5 blocks' worth
  my $oldfile = $d x $recs;
  my $flen = defined($FLEN) ? $FLEN : $recs * 17;
  substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
  print F $oldfile;
  close F;

  die "wrong length!" unless -s $file == $flen;

  my $newdata = "-" x $newlen;
  my $expected = $oldfile;
  my $old = defined $len ? substr($expected, $pos, $len) 
                         : substr($expected, $pos);
  $old = "$newdata$old";
  my $x_retval;
  if (defined $len) {
    substr($expected, $pos, $len, substr($old, 0, $len, ""));
    $x_retval = $old;
  } else {
    substr($expected, $pos) = $old;
    $x_retval = "";
  }

  my $o = tie my @lines, 'Tie::File', $file or die $!;
  local $SIG{ALRM} = sub { die "Alarm clock" };
  my $a_retval = eval { alarm(5) unless $^P; $o->_downcopy($newdata, $pos, $len) };
  my $err = $@;
  undef $o; untie @lines; alarm(0);
  if ($err) {
    if ($err =~ /^Alarm clock/) {
      print "# Timeout\n";
      print "not ok $N\n"; $N++;
      print "not ok $N\n"; $N++;
      return;
    } else {
      $@ = $err;
      die;
    }
  }

  open F, "< $file" or die "Couldn't open file $file: $!";
  binmode F;
  my $actual;
  { local $/;
    $actual = <F>;
  }
  close F;

  my ($alen, $xlen) = (length $actual, length $expected);
  unless ($alen == $xlen) {
    my @ARGS = @_;
    for (@ARGS) { $_ = "UNDEF" unless defined }
    print "# try(@ARGS) expected file length $xlen, actual $alen!\n";
  }
  print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
  $N++;
  print $a_retval eq $x_retval ? "ok $N\n" : "not ok $N\n";
  $N++;

  if (defined $len) {
    try($pos, undef, $newlen);
  }
}



use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq "$c[$_]$:") {
      $msg = "expected <$c[$_]$:>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}

--- NEW FILE: 26_twrite.t ---
#!/usr/bin/perl
#
# Unit tests of _twrite function
#
# _twrite($self, $data, $pos, $len)
#
# 't' here is for 'tail'.  This writes $data at absolute position $pos
# in the file, overwriting exactly $len of the bytes at that position.
# Everything else is moved down or up, dependong on whether
# length($data) > $len or length($data) < $len.
# $len == 0 is a pure insert; $len == length($data) is a simple overwrite.
#

my $file = "tf$$.txt";

print "1..181\n";

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

$: = Tie::File::_default_recsep();

# (2) Peter Scott sent this one.  It fails in 0.51 and works in 0.90
# <4.3.2.7.2.20020331102819.00b913d0 at shell2.webquarry.com>
#
# The problem was premature termination in the inner loop
# because you had $more_data scoped *inside* the block instead of outside.
# 20020331
open F, "> $file" or die "Couldn't open $file: $!";
binmode F;
for (1..100) {
  print F "$_ ", 'a'x150, $: ;
}
close F;
# The file is now 15292 characters long on Unix, 15392 on Win32
die -s $file unless -s $file == 15292 + 100 * length($:);

tie my @lines, 'Tie::File', $file or die $!;
push @lines, "1001 ".('a' x 100);
splice @lines, 0, 1;
untie @lines;

my $s = -s $file;
my $x = 15292 - 152 + 105 + 100*length($:);
print $s == $x
  ? "ok $N\n" : "not ok $N # expected $x, got $s\n";
$N++;

my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);

# (3-73) These were generated by 'gentests.pl' to cover all possible cases
# (I hope)
# Legend:
#         x: data is entirely contained within one block
#        x>: data runs from the middle to the end of the block
#        <x: data runs from the start to the middle of the block
#       <x>: data occupies precisely one block
#      x><x: data overlaps one block boundary
#     <x><x: data runs from the start of one block into the middle of the next
#     x><x>: data runs from the middle of one block to the end of the next
#    <x><x>: data occupies two blocks exactly
# <x><x><x>: data occupies three blocks exactly
#         0: data is null
#
# For each possible alignment of the old and new data, we investigate
# up to three situations: old data is shorter, old and new data are the
# same length, and new data is shorter.
#
# try($pos, $old, $new) means to run a test where the data starts at 
# position $pos, the old data has length $old,
# and the new data has length $new.
try( 9659,  6635,  6691);  # old=x        , new=x        ; old < new
try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
try( 8394,     0,  5742);  # old=0        , new=x        ; old < new
try( 8192,  2819,  6738);  # old=<x       , new=<x       ; old < new
try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
try( 8192,     0,  6870);  # old=0        , new=<x       ; old < new
try( 8478,  6259,  7906);  # old=x        , new=x>       ; old < new
try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
try( 9759,     0,  6625);  # old=0        , new=x>       ; old < new
try( 8525,  2081,  8534);  # old=x        , new=x><x     ; old < new
try(15550,   834,  1428);  # old=x>       , new=x><x     ; old < new
try(14966,  1668,  3479);  # old=x><x     , new=x><x     ; old < new
try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
try(12602,     0,  8354);  # old=0        , new=x><x     ; old < new
try( 8192,  2767,  8192);  # old=<x       , new=<x>      ; old < new
try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try( 8192,     0,  8192);  # old=0        , new=<x>      ; old < new
try( 8192,  6532, 10882);  # old=<x       , new=<x><x    ; old < new
try( 8192,  8192, 16044);  # old=<x>      , new=<x><x    ; old < new
try( 8192,  9555, 11020);  # old=<x><x    , new=<x><x    ; old < new
try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
try( 8192,     0, 12488);  # old=0        , new=<x><x    ; old < new
try( 8222,  6385, 16354);  # old=x        , new=x><x>    ; old < new
try(13500,  2884, 11076);  # old=x>       , new=x><x>    ; old < new
try(14069,  4334, 10507);  # old=x><x     , new=x><x>    ; old < new
try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
try(10469,     0, 14107);  # old=0        , new=x><x>    ; old < new
try( 8192,  4181, 16384);  # old=<x       , new=<x><x>   ; old < new
try( 8192,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try( 8192, 12087, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try( 8192,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try( 8192,  4968, 24576);  # old=<x       , new=<x><x><x>; old < new
try( 8192,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try( 8192, 14163, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try( 8192, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try( 8192,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try( 8771,   776,     0);  # old=x        , new=0        ; old > new
try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(10489,     0,     0);  # old=0        , new=0        ; old = new

# (74-114)
# These tests all take place at the start of the file
try(    0,   771,  1593);  # old=<x       , new=<x       ; old < new
try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
try(    0,     0,  1317);  # old=0        , new=<x       ; old < new
try(    0,  5609,  8192);  # old=<x       , new=<x>      ; old < new
try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(    0,     0,  8192);  # old=0        , new=<x>      ; old < new
try(    0,  6265,  9991);  # old=<x       , new=<x><x    ; old < new
try(    0,  8192, 16119);  # old=<x>      , new=<x><x    ; old < new
try(    0, 10218, 11888);  # old=<x><x    , new=<x><x    ; old < new
try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
try(    0,     0, 10881);  # old=0        , new=<x><x    ; old < new
try(    0,  6448, 16384);  # old=<x       , new=<x><x>   ; old < new
try(    0,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try(    0, 15082, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(    0,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(    0,  2421, 24576);  # old=<x       , new=<x><x><x>; old < new
try(    0,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try(    0, 11655, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try(    0, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(    0,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(    0,     0,     0);  # old=0        , new=0        ; old = new

# (115-141)
# These tests all take place at the end of the file
$FLEN = 40960;  # Force the file to be exactly 40960 bytes long
try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
try(40960,     0,  2779);  # old=0        , new=<x       ; old < new
try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
try(40960,     0,  8192);  # old=0        , new=<x>      ; old < new
try(32768,  8192, 10724);  # old=<x>      , new=<x><x    ; old < new
try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
try(40960,     0, 11752);  # old=0        , new=<x><x    ; old < new
try(32768,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
try(40960,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(32768,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
try(24576, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
try(40960,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
try(40960,     0,     0);  # old=0        , new=0        ; old = new

# (142-181)
# These tests all take place at the end of the file
$FLEN = 42000;  # Force the file to be exactly 42000 bytes long
try(41275,   725,  4059);  # old=x        , new=x        ; old < new
try(41683,   317,   317);  # old=x        , new=x        ; old = new
try(41225,   775,   405);  # old=x        , new=x        ; old > new
try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
try(42000,     0,  2434);  # old=0        , new=x        ; old < new
try(40960,  1040,  1608);  # old=<x       , new=<x       ; old < new
try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
try(42000,     0,  6637);  # old=0        , new=<x       ; old < new
try(41022,   978,  8130);  # old=x        , new=x>       ; old < new
try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
try(42000,     0,  7152);  # old=0        , new=x>       ; old < new
try(41613,   387, 10601);  # old=x        , new=x><x     ; old < new
try(38460,  3540,  3938);  # old=x><x     , new=x><x     ; old < new
try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
try(42000,     0,  9189);  # old=0        , new=x><x     ; old < new
try(40960,  1040,  8192);  # old=<x       , new=<x>      ; old < new
try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
try(42000,     0,  8192);  # old=0        , new=<x>      ; old < new
try(40960,  1040, 11778);  # old=<x       , new=<x><x    ; old < new
try(32768,  9232, 13792);  # old=<x><x    , new=<x><x    ; old < new
try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
try(42000,     0,  8578);  # old=0        , new=<x><x    ; old < new
try(41531,   469, 15813);  # old=x        , new=x><x>    ; old < new
try(39618,  2382,  9534);  # old=x><x     , new=x><x>    ; old < new
try(42000,     0, 15344);  # old=0        , new=x><x>    ; old < new
try(40960,  1040, 16384);  # old=<x       , new=<x><x>   ; old < new
try(32768,  9232, 16384);  # old=<x><x    , new=<x><x>   ; old < new
try(42000,     0, 16384);  # old=0        , new=<x><x>   ; old < new
try(40960,  1040, 24576);  # old=<x       , new=<x><x><x>; old < new
try(32768,  9232, 24576);  # old=<x><x    , new=<x><x><x>; old < new
try(42000,     0, 24576);  # old=0        , new=<x><x><x>; old < new
try(41500,   500,     0);  # old=x        , new=0        ; old > new
try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
try(42000,     0,     0);  # old=0        , new=0        ; old = new

sub try {
  my ($pos, $len, $newlen) = @_;
  open F, "> $file" or die "Couldn't open file $file: $!";
  binmode F;

  # The record has exactly 17 characters.  This will help ensure that
  # even if _twrite screws up, the data doesn't coincidentally
  # look good because the remainder accidentally lines up.
  my $d = substr("0123456789abcdef$:", -17);
  my $recs = defined($FLEN) ?
    int($FLEN/length($d))+1 : # enough to make up at least $FLEN
    int(8192*5/length($d))+1; # at least 5 blocks' worth
  my $oldfile = $d x $recs;
  my $flen = defined($FLEN) ? $FLEN : $recs * 17;
  substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
  print F $oldfile;
  close F;

  die "wrong length!" unless -s $file == $flen;

  my $newdata = "-" x $newlen;
  my $expected = $oldfile;
  substr($expected, $pos, $len) = $newdata;

  my $o = tie my @lines, 'Tie::File', $file or die $!;
  $o->_twrite($newdata, $pos, $len);
  undef $o; untie @lines;

  open F, "< $file" or die "Couldn't open file $file: $!";
  binmode F;
  my $actual;
  { local $/;
    $actual = <F>;
  }
  close F;

  my ($alen, $xlen) = (length $actual, length $expected);
  unless ($alen == $xlen) {
    print "# try(@_) expected file length $xlen, actual $alen!\n";
  }
  print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
  $N++;
}



use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq "$c[$_]$:") {
      $msg = "expected <$c[$_]$:>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 11_rv_splice_rs.t ---
#!/usr/bin/perl
#
# Check SPLICE function's return value
# (04_splice.t checks its effect on the file)
#

my $file = "tf$$.txt";
my $data = "rec0blahrec1blahrec2blah";

print "1..50\n";

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

init_file($data);

my $o = tie @a, 'Tie::File', $file, autochomp => 0, recsep => 'blah';
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

my $n;

# (3-12) splicing at the beginning
@r = splice(@a, 0, 0, "rec4");
check_result();
@r = splice(@a, 0, 1, "rec5");       # same length
check_result("rec4");
@r = splice(@a, 0, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, 0, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 0, 1);               # removal
check_result("r5");
@r = splice(@a, 0, 0);               # no-op
check_result();
@r = splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 0, 2);               # delete more than one
check_result('record9', 'rec10');


# (13-22) splicing in the middle
@r = splice(@a, 1, 0, "rec4");
check_result();
@r = splice(@a, 1, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 1, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, 1, 1);               # removal
check_result("r5");
@r = splice(@a, 1, 0);               # no-op
check_result();
@r = splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 1, 2);               # delete more than one
check_result('record9','rec10');

# (23-32) splicing at the end
@r = splice(@a, 3, 0, "rec4");
check_result();
@r = splice(@a, 3, 1, "rec5");       # same length
check_result('rec4');
@r = splice(@a, 3, 1, "record5");    # longer
check_result('rec5');

@r = splice(@a, 3, 1, "r5");         # shorter
check_result('record5');
@r = splice(@a, 3, 1);               # removal
check_result('r5');
@r = splice(@a, 3, 0);               # no-op
check_result();
@r = splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('r7', 'rec8');

@r = splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, 3, 2);               # delete more than one
check_result('record9', 'rec10');

# (33-42) splicing with negative subscript
@r = splice(@a, -1, 0, "rec4");
check_result();
@r = splice(@a, -1, 1, "rec5");       # same length
check_result('rec2');
@r = splice(@a, -1, 1, "record5");    # longer
check_result("rec5");

@r = splice(@a, -1, 1, "r5");         # shorter
check_result("record5");
@r = splice(@a, -1, 1);               # removal
check_result("r5");
@r = splice(@a, -1, 0);               # no-op  
check_result();
@r = splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check_result();
@r = splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_result('rec4');

@r = splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check_result('rec7', 'record8', 'rec9');
@r = splice(@a, -4, 3);               # delete more than one
check_result('r7', 'rec8', 'record9');

# (43) scrub it all out
@r = splice(@a, 0, 3);
check_result('rec0', 'rec1', 'rec10');

# (44) put some back in
@r = splice(@a, 0, 0, "rec0", "rec1");
check_result();

# (45) what if we remove too many records?
@r = splice(@a, 0, 17);
check_result('rec0', 'rec1');

# (46-48) Now check the scalar context return
splice(@a, 0, 0, qw(I like pie));
my $r;
$r = splice(@a, 0, 0);
print !defined($r) ? "ok $N\n" : "not ok $N \# return should have been undef\n";
$N++;

$r = splice(@a, 2, 1);
print $r eq "pieblah" ? "ok $N\n" : "not ok $N \# return should have been 'pie'\n";
$N++;

$r = splice(@a, 0, 2);
print $r eq "likeblah" ? "ok $N\n" : "not ok $N \# return should have been 'like'\n";
$N++;

# (49-50) Test default arguments
splice @a, 0, 0, (0..11);
@r = splice @a, 4;
check_result(4..11);
@r = splice @a;
check_result(0..3);

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

# actual results are in @r.
# expected results are in @_
sub check_result {
  my @x = @_;
  s/blah$// for @r;
  my $good = 1;
  $good = 0 unless @r == @x;
  for my $i (0 .. $#r) {
    $good = 0 unless $r[$i] eq $x[$i];
  }
  print $good ? "ok $N\n" : "not ok $N \# was (@r); should be (@x)\n";
  $N++;
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 03_longfetch.t ---
#!/usr/bin/perl
#
# Make sure we can fetch a record in the middle of the file
# before we've ever looked at any records before it
#
# Make sure fetching past the end of the file returns the undefined value
#
# (tests _fill_offsets_to() )
#

my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";

print "1..8\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;


my $o = tie @a, 'Tie::File', $file, autochomp => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};

my $n;

# 3-5
for (2, 1, 0) {
  my $rec = $a[$_];
  print $rec eq "rec$_$:" ? "ok $N\n" : "not ok $N # rec=<$rec> ?\n";
  $N++;
}

# 6-8
for (3, 4, 6) {
  my $rec = $a[$_];
  print ((not defined $rec) ? "ok $N\n" : "not ok $N # rec=<$rec> is defined\n");
  $N++;
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 25_gen_nocache.t ---
#!/usr/bin/perl
#
# Regular read-write tests with caching disabled
# (Same as 01_gen.t)
#
my $file = "tf$$.txt";

print "1..68\n";

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

my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0, memory => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};

# 3-5 create
$a[0] = 'rec0';
check_contents("rec0");

# 6-11 append
$a[1] = 'rec1';
check_contents("rec0", "rec1");
$a[2] = 'rec2';
check_contents("rec0", "rec1", "rec2");

# 12-20 same-length alterations
$a[0] = 'new0';
check_contents("new0", "rec1", "rec2");
$a[1] = 'new1';
check_contents("new0", "new1", "rec2");
$a[2] = 'new2';
check_contents("new0", "new1", "new2");

# 21-35 lengthening alterations
$a[0] = 'long0';
check_contents("long0", "new1", "new2");
$a[1] = 'long1';
check_contents("long0", "long1", "new2");
$a[2] = 'long2';
check_contents("long0", "long1", "long2");
$a[1] = 'longer1';
check_contents("long0", "longer1", "long2");
$a[0] = 'longer0';
check_contents("longer0", "longer1", "long2");

# 36-50 shortening alterations, including truncation
$a[0] = 'short0';
check_contents("short0", "longer1", "long2");
$a[1] = 'short1';
check_contents("short0", "short1", "long2");
$a[2] = 'short2';
check_contents("short0", "short1", "short2");
$a[1] = 'sh1';
check_contents("short0", "sh1", "short2");
$a[0] = 'sh0';
check_contents("sh0", "sh1", "short2");

# (51-56) file with holes
$a[4] = 'rec4';
check_contents("sh0", "sh1", "short2", "", "rec4");
$a[3] = 'rec3';
check_contents("sh0", "sh1", "short2", "rec3", "rec4");

# (57-59) zero out file
@a = ();
check_contents();

# (60-62) insert into the middle of an empty file
$a[3] = "rec3";
check_contents("", "", "", "rec3");

# (63-68) 20020326 You thought there would be a bug in STORE where if
# a cached record was false, STORE wouldn't see it at all.  But you
# forgot that records always come back from the cache with the record
# separator attached, so they are unlikely to be false.  The only
# really weird case is when the cached record is empty and the record
# separator is "0".  Test that in 09_gen_rs.t.
$a[1] = "0";
check_contents("", "0", "", "rec3");
$a[1] = "whoops";
check_contents("", "whoops", "", "rec3");


use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq "$c[$_]$:") {
      $msg = "expected <$c[$_]$:>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 33_defer_vs.t ---
#!/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;
}


--- NEW FILE: 04_splice.t ---
#!/usr/bin/perl

#
# Check SPLICE function's effect on the file
# (07_rv_splice.t checks its return value)
#
# Each call to 'check_contents' actually performs two tests.
# First, it calls the tied object's own 'check_integrity' method,
# which makes sure that the contents of the read cache and offset tables
# accurately reflect the contents of the file.  
# Then, it checks the actual contents of the file against the expected
# contents.


$| = 1;
my $file = "tf$$.txt";
$: = Tie::File::_default_recsep();
my $data = "rec0$:rec1$:rec2$:";
print "1..118\n";

init_file($data);

my $N = 1;
use Tie::File;
print "ok $N\n"; $N++;  # partial credit just for showing up

my $o = tie @a, 'Tie::File', $file;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};
my $n;

# (3-22) splicing at the beginning
splice(@a, 0, 0, "rec4");
check_contents("rec4$:$data");
splice(@a, 0, 1, "rec5");       # same length
check_contents("rec5$:$data");
splice(@a, 0, 1, "record5");    # longer
check_contents("record5$:$data");

splice(@a, 0, 1, "r5");         # shorter
check_contents("r5$:$data");
splice(@a, 0, 1);               # removal
check_contents("$data");
splice(@a, 0, 0);               # no-op
check_contents("$data");
splice(@a, 0, 0, 'r7', 'rec8'); # insert more than one
check_contents("r7$:rec8$:$data");
splice(@a, 0, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec7$:record8$:rec9$:$data");

splice(@a, 0, 3, 'record9', 'rec10'); # delete more than insert
check_contents("record9$:rec10$:$data");
splice(@a, 0, 2);               # delete more than one
check_contents("$data");


# (23-42) splicing in the middle
splice(@a, 1, 0, "rec4");
check_contents("rec0$:rec4$:rec1$:rec2$:");
splice(@a, 1, 1, "rec5");       # same length
check_contents("rec0$:rec5$:rec1$:rec2$:");
splice(@a, 1, 1, "record5");    # longer
check_contents("rec0$:record5$:rec1$:rec2$:");

splice(@a, 1, 1, "r5");         # shorter
check_contents("rec0$:r5$:rec1$:rec2$:");
splice(@a, 1, 1);               # removal
check_contents("$data");
splice(@a, 1, 0);               # no-op
check_contents("$data");
splice(@a, 1, 0, 'r7', 'rec8'); # insert more than one
check_contents("rec0$:r7$:rec8$:rec1$:rec2$:");
splice(@a, 1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec0$:rec7$:record8$:rec9$:rec1$:rec2$:");

splice(@a, 1, 3, 'record9', 'rec10'); # delete more than insert
check_contents("rec0$:record9$:rec10$:rec1$:rec2$:");
splice(@a, 1, 2);               # delete more than one
check_contents("$data");

# (43-62) splicing at the end
splice(@a, 3, 0, "rec4");
check_contents("$ {data}rec4$:");
splice(@a, 3, 1, "rec5");       # same length
check_contents("$ {data}rec5$:");
splice(@a, 3, 1, "record5");    # longer
check_contents("$ {data}record5$:");

splice(@a, 3, 1, "r5");         # shorter
check_contents("$ {data}r5$:");
splice(@a, 3, 1);               # removal
check_contents("$data");
splice(@a, 3, 0);               # no-op
check_contents("$data");
splice(@a, 3, 0, 'r7', 'rec8'); # insert more than one
check_contents("$ {data}r7$:rec8$:");
splice(@a, 3, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("$ {data}rec7$:record8$:rec9$:");

splice(@a, 3, 3, 'record9', 'rec10'); # delete more than insert
check_contents("$ {data}record9$:rec10$:");
splice(@a, 3, 2);               # delete more than one
check_contents("$data");

# (63-82) splicing with negative subscript
splice(@a, -1, 0, "rec4");
check_contents("rec0$:rec1$:rec4$:rec2$:");
splice(@a, -1, 1, "rec5");       # same length
check_contents("rec0$:rec1$:rec4$:rec5$:");
splice(@a, -1, 1, "record5");    # longer
check_contents("rec0$:rec1$:rec4$:record5$:");

splice(@a, -1, 1, "r5");         # shorter
check_contents("rec0$:rec1$:rec4$:r5$:");
splice(@a, -1, 1);               # removal
check_contents("rec0$:rec1$:rec4$:");
splice(@a, -1, 0);               # no-op  
check_contents("rec0$:rec1$:rec4$:");
splice(@a, -1, 0, 'r7', 'rec8'); # insert more than one
check_contents("rec0$:rec1$:r7$:rec8$:rec4$:");
splice(@a, -1, 2, 'rec7', 'record8', 'rec9'); # insert more than delete
check_contents("rec0$:rec1$:r7$:rec8$:rec7$:record8$:rec9$:");

splice(@a, -3, 3, 'record9', 'rec10'); # delete more than insert
check_contents("rec0$:rec1$:r7$:rec8$:record9$:rec10$:");
splice(@a, -4, 3);               # delete more than one
check_contents("rec0$:rec1$:rec10$:");

# (83-84) scrub it all out
splice(@a, 0, 3);
check_contents("");

# (85-86) put some back in
splice(@a, 0, 0, "rec0", "rec1");
check_contents("rec0$:rec1$:");

# (87-88) what if we remove too many records?
splice(@a, 0, 17);
check_contents("");

# (89-92) In the past, splicing past the end was not correctly detected
# (1.14)
splice(@a, 89, 3);
check_contents("");
splice(@a, @a, 3);
check_contents("");

# (93-96) Also we did not emulate splice's freaky behavior when inserting
# past the end of the array (1.14)
splice(@a, 89, 0, "I", "like", "pie");
check_contents("I$:like$:pie$:");
splice(@a, 89, 0, "pie pie pie");
check_contents("I$:like$:pie$:pie pie pie$:");

# (97) Splicing with too large a negative number should be fatal
# This test ignored because it causes 5.6.1 and 5.7.3 to dump core
# It also garbles the stack under 5.005_03 (20020401)
# NOT MY FAULT
if ($] > 5.007003) {
  eval { splice(@a, -7, 0) };
  print $@ =~ /^Modification of non-creatable array value attempted, subscript -7/
      ? "ok $N\n" : "not ok $N \# \$\@ was '$@'\n";
} else { 
  print "ok $N \# skipped (versions through 5.7.3 dump core here.)\n";
}
$N++;
       
# (98-101) Test default arguments
splice @a, 0, 0, (0..11);
splice @a, 4;
check_contents("0$:1$:2$:3$:");
splice @a;
check_contents("");

# (102-103) I think there's a bug here---it will fail to clear the EOF flag
@a = (0..11);
splice @a, -1, 1000;
check_contents("0$:1$:2$:3$:4$:5$:6$:7$:8$:9$:10$:");

# (104-106) make sure that undefs are treated correctly---they should
# be converted to empty records, and should not raise any warnings.
# (Some of these failed in 0.90.  The change to _fixrec fixed them.)
# 20020331
{
  my $good = 1; my $warn;
  # If any of these raise warnings, we have a problem.
  local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)};
  local $^W = 1;
  @a = (1);
  splice @a, 1, 0, undef, undef, undef;
  print $good ? "ok $N\n" : "not ok $N # $warn\n";
  $N++; $good = 1;
  print defined($a[2]) ? "ok $N\n" : "not ok $N\n";
  $N++; $good = 1;
  my @r = splice @a, 2;
  print defined($r[0]) ? "ok $N\n" : "not ok $N\n";
  $N++; $good = 1;
}

# (107-118) splice with negative length was treated wrong
# 20020402 Reported by Juerd Waalboer
@a = (0..8) ;
splice @a, 0, -3;
check_contents("6$:7$:8$:");
@a = (0..8) ;
splice @a, 1, -3;
check_contents("0$:6$:7$:8$:");
@a = (0..8) ;
splice @a, 7, -3;
check_contents("0$:1$:2$:3$:4$:5$:6$:7$:8$:");
@a = (0..2) ;
splice @a, 0, -3;
check_contents("0$:1$:2$:");
@a = (0..2) ;
splice @a, 1, -3;
check_contents("0$:1$:2$:");
@a = (0..2) ;
splice @a, 7, -3;
check_contents("0$:1$:2$:");

sub init_file {
  my $data = shift;
  open F, "> $file" or die $!;
  binmode F;
  print F $data;
  close F;
}

use POSIX 'SEEK_SET';
sub check_contents {
  my $x = shift;
  my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY});
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
  print $integrity ? "ok $N\n" : "not ok $N\n";
  $N++;
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;
}


sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}


--- NEW FILE: 24_cache_loop.t ---
#!/usr/bin/perl
#
# Tests for various caching errors
#

use Config;
my $file = "tf$$.txt";
unless ($Config{d_alarm}) {
  print "1..0\n"; exit;
}

$: = Tie::File::_default_recsep();
my $data = join $:, "record0" .. "record9", "";
my $V = $ENV{INTEGRITY};        # Verbose integrity checking?

print "1..3\n";

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

open F, "> $file" or die $!;
binmode F;
print F $data;
close F;

# Limit cache size to 30 bytes 
my $MAX = 30;
#  -- that's enough space for 3 records, but not 4, on both \n and \r\n systems
my $o = tie @a, 'Tie::File', $file, memory => $MAX, autodefer => 1;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

# (3) In 0.50 this goes into an infinite loop.  Explanation:
#
#   Suppose you overfill the defer buffer by so much that the memory
#   limit is also exceeded.  You'll go into _splice to prepare to
#   write out the defer buffer, and _splice will call _fetch, which
#   will then try to flush the read cache---but the read cache is
#   already empty, so you're stuck in an infinite loop.
#
# Five seconds should be plenty of time for it to complete if it works.
alarm 5 unless $^P;
@a = "record0" .. "record9";
print "ok 3\n";
alarm 0;

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}




--- NEW FILE: 01_gen.t ---
#!/usr/bin/perl

$| = 1;
my $file = "tf$$.txt";
1 while unlink $file;

print "1..75\n";

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

my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0;
print $o ? "ok $N\n" : "not ok $N\n";
$N++;

$: = $o->{recsep};

# 3-5 create
$a[0] = 'rec0';
check_contents("rec0");

# 6-11 append
$a[1] = 'rec1';
check_contents("rec0", "rec1");
$a[2] = 'rec2';
check_contents("rec0", "rec1", "rec2");

# 12-20 same-length alterations
$a[0] = 'new0';
check_contents("new0", "rec1", "rec2");
$a[1] = 'new1';
check_contents("new0", "new1", "rec2");
$a[2] = 'new2';
check_contents("new0", "new1", "new2");

# 21-35 lengthening alterations
$a[0] = 'long0';
check_contents("long0", "new1", "new2");
$a[1] = 'long1';
check_contents("long0", "long1", "new2");
$a[2] = 'long2';
check_contents("long0", "long1", "long2");
$a[1] = 'longer1';
check_contents("long0", "longer1", "long2");
$a[0] = 'longer0';
check_contents("longer0", "longer1", "long2");

# 36-50 shortening alterations, including truncation
$a[0] = 'short0';
check_contents("short0", "longer1", "long2");
$a[1] = 'short1';
check_contents("short0", "short1", "long2");
$a[2] = 'short2';
check_contents("short0", "short1", "short2");
$a[1] = 'sh1';
check_contents("short0", "sh1", "short2");
$a[0] = 'sh0';
check_contents("sh0", "sh1", "short2");

# (51-56) file with holes
$a[4] = 'rec4';
check_contents("sh0", "sh1", "short2", "", "rec4");
$a[3] = 'rec3';
check_contents("sh0", "sh1", "short2", "rec3", "rec4");

# (57-59) zero out file
@a = ();
check_contents();

# (60-62) insert into the middle of an empty file
$a[3] = "rec3";
check_contents("", "", "", "rec3");

# (63-68) 20020326 You thought there would be a bug in STORE where if
# a cached record was false, STORE wouldn't see it at all.  But you
# forgot that records always come back from the cache with the record
# separator attached, so they are unlikely to be false.  The only
# really weird case is when the cached record is empty and the record
# separator is "0".  Test that in 09_gen_rs.t.
$a[1] = "0";
check_contents("", "0", "", "rec3");
$a[1] = "whoops";
check_contents("", "whoops", "", "rec3");

# (69-72) make sure that undefs are treated correctly---they should 
# be converted to empty records, and should not raise any warnings.
# (Some of these failed in 0.90.  The change to _fixrec fixed them.)
# 20020331
{
  my $good = 1; my $warn;
  # If any of these raise warnings, we have a problem.
  local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)};
  local $^W = 1;
  @a = (1);
  $a[0] = undef;
  print $good ? "ok $N\n" : "not ok $N # $warn\n";
  $N++; $good = 1;
  print defined($a[0]) ? "ok $N\n" : "not ok $N\n";
  $N++; $good = 1;
  $a[3] = '3';
  print defined($a[1]) ? "ok $N\n" : "not ok $N\n";
  $N++; $good = 1;
  undef $a[3];
  print $good ? "ok $N\n" : "not ok $N # $warn\n";
  $N++; $good = 1;
}

# (73-75) What if the user has tampered with $\ ?
{ {  local $\ = "stop messing with the funny variables!";
     @a = (0..2);
   }
  check_contents(0..2);
}

use POSIX 'SEEK_SET';
sub check_contents {
  my @c = @_;
  my $x = join $:, @c, '';
  local *FH = $o->{fh};
  seek FH, 0, SEEK_SET;
#  my $open = open FH, "< $file";
  my $a;
  { local $/; $a = <FH> }
  $a = "" unless defined $a;
  if ($a eq $x) {
    print "ok $N\n";
  } else {
    ctrlfix($a, $x);
    print "not ok $N\n# expected <$x>, got <$a>\n";
  }
  $N++;

  # now check FETCH:
  my $good = 1;
  my $msg;
  for (0.. $#c) {
    my $aa = $a[$_];
    unless ($aa eq "$c[$_]$:") {
      $msg = "expected <$c[$_]$:>, got <$aa>";
      ctrlfix($msg);
      $good = 0;
    }
  }
  print $good ? "ok $N\n" : "not ok $N # $msg\n";
  $N++;

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

sub ctrlfix {
  for (@_) {
    s/\n/\\n/g;
    s/\r/\\r/g;
  }
}

END {
  undef $o;
  untie @a;
  1 while unlink $file;
}





More information about the dslinux-commit mailing list