29_downcopy.t

source of perl for linux application,

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