1N/A#!/usr/bin/perl
1N/A#
1N/A# Unit tests of _upcopy function
1N/A#
1N/A# _upcopy($self, $source, $dest, $len)
1N/A#
1N/A# Take a block of data of leength $len at $source and copy it
1N/A# to $dest, which must be <= $source but which need not be <= $source - $len
1N/A# (That is, this will only copy a block to a position earlier in the file,
1N/A# but the source and destination regions may overlap.)
1N/A
1N/A
1N/Amy $file = "tf$$.txt";
1N/A
1N/Aprint "1..55\n";
1N/A
1N/Amy $N = 1;
1N/Ause Tie::File;
1N/Aprint "ok $N\n"; $N++;
1N/A
1N/A$: = Tie::File::_default_recsep();
1N/A
1N/Amy @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
1N/A
1N/A$FLEN = 40970; # 2410 records of 17 chars each
1N/A
1N/A# (2-7) Trivial non-moves at start of file
1N/Atry(0, 0, 0);
1N/Atry(0, 0, 10);
1N/Atry(0, 0, 100);
1N/Atry(0, 0, 1000);
1N/Atry(0, 0, 10000);
1N/Atry(0, 0, 20000);
1N/A
1N/A# (8-13) Trivial non-moves in middle of file
1N/Atry(100, 100, 0);
1N/Atry(100, 100, 10);
1N/Atry(100, 100, 100);
1N/Atry(100, 100, 1000);
1N/Atry(100, 100, 10000);
1N/Atry(100, 100, 20000);
1N/A
1N/A# (14) Trivial non-move at end of file
1N/Atry($FLEN, $FLEN, 0);
1N/A
1N/A# (15-17) Trivial non-move of tail of file
1N/Atry(0, 0, undef);
1N/Atry(100, 100, undef);
1N/Atry($FLEN, $FLEN, undef);
1N/A
1N/A# (18-24) Moves to start of file
1N/Atry(100, 0, 0);
1N/Atry(100, 0, 10);
1N/Atry(100, 0, 100);
1N/Atry(100, 0, 1000);
1N/Atry(100, 0, 10000);
1N/Atry(100, 0, 20000);
1N/Atry(100, 0, undef);
1N/A
1N/A# (25-31) Moves in middle of file
1N/Atry(200, 100, 0);
1N/Atry(200, 100, 10);
1N/Atry(200, 100, 100);
1N/Atry(200, 100, 1000);
1N/Atry(200, 100, 10000);
1N/Atry(200, 100, 20000);
1N/Atry(200, 100, undef);
1N/A
1N/A# (32-43) Moves from end of file
1N/Atry($FLEN, 10000, 0);
1N/Atry($FLEN-10, 10000, 10);
1N/Atry($FLEN-100, 10000, 100);
1N/Atry($FLEN-1000, 200, 1000);
1N/Atry($FLEN-10000, 200, 10000);
1N/Atry($FLEN-20000, 200, 20000);
1N/Atry($FLEN, 10000, undef);
1N/Atry($FLEN-10, 10000, undef);
1N/Atry($FLEN-100, 10000, undef);
1N/Atry($FLEN-1000, 200, undef);
1N/Atry($FLEN-10000, 200, undef);
1N/Atry($FLEN-20000, 200, undef);
1N/A
1N/A$FLEN = 40960;
1N/A
1N/A# (44-55) Moves from end of file when file ends on a block boundary
1N/Atry($FLEN, 10000, 0);
1N/Atry($FLEN-10, 10000, 10);
1N/Atry($FLEN-100, 10000, 100);
1N/Atry($FLEN-1000, 200, 1000);
1N/Atry($FLEN-10000, 200, 10000);
1N/Atry($FLEN-20000, 200, 20000);
1N/Atry($FLEN, 10000, undef);
1N/Atry($FLEN-10, 10000, undef);
1N/Atry($FLEN-100, 10000, undef);
1N/Atry($FLEN-1000, 200, undef);
1N/Atry($FLEN-10000, 200, undef);
1N/Atry($FLEN-20000, 200, undef);
1N/A
1N/Asub try {
1N/A my ($src, $dst, $len) = @_;
1N/A open F, "> $file" or die "Couldn't open file $file: $!";
1N/A binmode F;
1N/A
1N/A # The record has exactly 17 characters. This will help ensure that
1N/A # even if _upcopy screws up, the data doesn't coincidentally
1N/A # look good because the remainder accidentally lines up.
1N/A my $d = substr("0123456789abcdef$:", -17);
1N/A my $recs = defined($FLEN) ?
1N/A int($FLEN/length($d))+1 : # enough to make up at least $FLEN
1N/A int(8192*5/length($d))+1; # at least 5 blocks' worth
1N/A my $oldfile = $d x $recs;
1N/A my $flen = defined($FLEN) ? $FLEN : $recs * 17;
1N/A substr($oldfile, $FLEN) = "" if defined $FLEN; # truncate
1N/A print F $oldfile;
1N/A close F;
1N/A
1N/A die "wrong length!" unless -s $file == $flen;
1N/A
1N/A # If len is specified, use that. If it's undef,
1N/A # then behave *as if* we had specified the whole rest of the file
1N/A my $expected = $oldfile;
1N/A if (defined $len) {
1N/A substr($expected, $dst, $len) = substr($expected, $src, $len);
1N/A } else {
1N/A substr($expected, $dst) = substr($expected, $src);
1N/A }
1N/A
1N/A my $o = tie my @lines, 'Tie::File', $file or die $!;
1N/A local $SIG{ALRM} = sub { die "Alarm clock" };
1N/A my $a_retval = eval { alarm(5) unless $^P; $o->_upcopy($src, $dst, $len) };
1N/A my $err = $@;
1N/A undef $o; untie @lines; alarm(0);
1N/A if ($err) {
1N/A if ($err =~ /^Alarm clock/) {
1N/A print "# Timeout\n";
1N/A print "not ok $N\n"; $N++;
1N/A return;
1N/A } else {
1N/A $@ = $err;
1N/A die;
1N/A }
1N/A }
1N/A
1N/A open F, "< $file" or die "Couldn't open file $file: $!";
1N/A binmode F;
1N/A my $actual;
1N/A { local $/;
1N/A $actual = <F>;
1N/A }
1N/A close F;
1N/A
1N/A my ($alen, $xlen) = (length $actual, length $expected);
1N/A unless ($alen == $xlen) {
1N/A print "# try(@_) expected file length $xlen, actual $alen!\n";
1N/A }
1N/A print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
1N/A $N++;
1N/A}
1N/A
1N/A
1N/A
1N/Ause POSIX 'SEEK_SET';
1N/Asub check_contents {
1N/A my @c = @_;
1N/A my $x = join $:, @c, '';
1N/A local *FH = $o->{fh};
1N/A seek FH, 0, SEEK_SET;
1N/A# my $open = open FH, "< $file";
1N/A my $a;
1N/A { local $/; $a = <FH> }
1N/A $a = "" unless defined $a;
1N/A if ($a eq $x) {
1N/A print "ok $N\n";
1N/A } else {
1N/A ctrlfix($a, $x);
1N/A print "not ok $N\n# expected <$x>, got <$a>\n";
1N/A }
1N/A $N++;
1N/A
1N/A # now check FETCH:
1N/A my $good = 1;
1N/A my $msg;
1N/A for (0.. $#c) {
1N/A my $aa = $a[$_];
1N/A unless ($aa eq "$c[$_]$:") {
1N/A $msg = "expected <$c[$_]$:>, got <$aa>";
1N/A ctrlfix($msg);
1N/A $good = 0;
1N/A }
1N/A }
1N/A print $good ? "ok $N\n" : "not ok $N # $msg\n";
1N/A $N++;
1N/A
1N/A print $o->_check_integrity($file, $ENV{INTEGRITY})
1N/A ? "ok $N\n" : "not ok $N\n";
1N/A $N++;
1N/A}
1N/A
1N/Asub ctrlfix {
1N/A for (@_) {
1N/A s/\n/\\n/g;
1N/A s/\r/\\r/g;
1N/A }
1N/A}
1N/A
1N/AEND {
1N/A undef $o;
1N/A untie @a;
1N/A 1 while unlink $file;
1N/A}
1N/A