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
#
# 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;
}