Gecko [ www.blackthorn-inc.com ]

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

Rename

#!/usr/bin/perl
#
# 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;
}