28_mtwrite.t

source of perl for linux application,

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