lib/Tie/File/t/28_mtwrite.t

   1 #!/usr/bin/perl
   2 #
   3 # Unit tests of _mtwrite function
   4 #
   5 # _mtwrite($self, $d1, $s1, $l1, $d2, $s2, $l2, ...)
   6 #
   7 # 'm' here is for 'multiple'.  This writes data $d1 at position $s1
   8 # over a block of space $l1, moving subsequent data up or down as necessary.
   9
  10 my $file = "tf$$.txt";
  11 $| = 1;
  12
  13 print "1..2252\n";
  14
  15 my $N = 1;
  16 my $oldfile;
  17 use Tie::File;
  18 print "ok $N\n"; $N++;
  19
  20 $: = Tie::File::_default_recsep();
  21
  22 # Only these are used for the triple-region tests
  23 @BASE_TRIES = (
  24                [10, 20, 30],
  25                [10, 30, 20],
  26                [100, 30, 20],
  27                [100, 20, 30],
  28                [100, 40, 20],
  29                [100, 20, 40],
  30                [200, 20, 30],
  31                [200, 30, 20],
  32                [200, 20, 60],
  33                [200, 60, 20],
  34                );
  35
  36 @TRIES = @BASE_TRIES;
  37
  38 $FLEN = 40970;   # Use files of this length
  39 $oldfile = mkrand($FLEN);
  40 print "# MOF tests\n";
  41 # These were generated by 'gentests.pl' to cover all possible cases
  42 # (I hope)
  43 # Legend:
  44 #         x: data is entirely contained within one block
  45 #        x>: data runs from the middle to the end of the block
  46 #        <x: data runs from the start to the middle of the block
  47 #       <x>: data occupies precisely one block
  48 #      x><x: data overlaps one block boundary
  49 #     <x><x: data runs from the start of one block into the middle of the next
  50 #     x><x>: data runs from the middle of one block to the end of the next
  51 #    <x><x>: data occupies two blocks exactly
  52 # <x><x><x>: data occupies three blocks exactly
  53 #         0: data is null
  54 #
  55 # For each possible alignment of the old and new data, we investigate
  56 # up to three situations: old data is shorter, old and new data are the
  57 # same length, and new data is shorter.
  58 #
  59 # try($pos, $old, $new) means to run a test where the area being
  60 # written into starts at position $pos, the area being written into
  61 # has length $old, and and the new data has length $new.
  62 try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
  63 try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
  64 try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
  65 try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
  66 try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
  67 try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
  68 try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
  69 try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
  70 try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
  71 try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
  72 try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
  73 try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
  74 try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
  75 try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
  76 try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
  77 try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
  78 try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
  79 try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
  80 try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
  81 try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
  82 try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
  83 try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
  84 try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
  85 try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
  86 try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
  87 try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
  88 try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
  89 try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
  90 try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
  91 try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
  92 try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
  93 try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
  94 try( 8771,   776,     0);  # old=x        , new=0        ; old > new
  95 try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
  96 try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
  97 try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
  98 try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
  99 try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
 100 try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
 101 try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 102 try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 103 try(10489,     0,     0);  # old=0        , new=0        ; old = new
 104
 105 print "# SOF tests\n";
 106 # These tests all take place at the start of the file
 107 try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
 108 try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
 109 try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
 110 try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
 111 try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
 112 try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
 113 try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
 114 try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
 115 try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
 116 try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
 117 try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
 118 try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
 119 try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
 120 try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
 121 try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
 122 try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
 123 try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
 124 try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
 125 try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
 126 try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
 127 try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
 128 try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 129 try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 130 try(    0,     0,     0);  # old=0        , new=0        ; old = new
 131
 132 print "# EOF tests 1\n";
 133 # These tests all take place at the end of the file
 134 $FLEN = 40960;  # Force the file to be exactly 40960 bytes long
 135 $oldfile = mkrand($FLEN);
 136 try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
 137 try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
 138 try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
 139 try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
 140 try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
 141 try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
 142 try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
 143 try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
 144 try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
 145 try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
 146 try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
 147 try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
 148 try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
 149 try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
 150 try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
 151 try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 152 try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 153 try(40960,     0,     0);  # old=0        , new=0        ; old = new
 154
 155 print "# EOF tests 2\n";
 156 # These tests all take place at the end of the file
 157 $FLEN = 42000;  # Force the file to be exactly 42000 bytes long
 158 $oldfile = mkrand($FLEN);
 159 try(41683,   317,   317);  # old=x        , new=x        ; old = new
 160 try(41225,   775,   405);  # old=x        , new=x        ; old > new
 161 try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
 162 try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
 163 try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
 164 try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
 165 try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
 166 try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
 167 try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
 168 try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
 169 try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
 170 try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
 171 try(41500,   500,     0);  # old=x        , new=0        ; old > new
 172 try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
 173 try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
 174 try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
 175 try(42000,     0,     0);  # old=0        , new=0        ; old = new
 176
 177 # Now the REAL tests
 178 # Make sure mtwrite can properly write sequences of several intervals
 179 # The intervals tested above were accumulated into @TRIES.
 180 # try_all_doubles() tries every possible sensible pair of those intervals.
 181 # try_all_triples() tries every possible sensible group of
 182 #  tree intervals from the more restrictive set @BASE_TRIES.
 183 $FLEN = 40970;
 184 $oldfile = mkrand($FLEN);
 185 try_all_doubles();
 186 try_all_triples();
 187
 188 sub mkrand {
 189   my $len = shift;
 190   srand $len;
 191   my @c = ('a' .. 'z', 'A' .. 'Z', 0..9, $:);
 192   my $d = "";
 193   $d .= $c[rand @c] until length($d) >= $len;
 194   substr($d, $len) = ""; # chop it off to the proper length
 195   $d;
 196 }
 197
 198 sub try {
 199   push @TRIES, [@_] if @_ == 3;
 200
 201   open F, "> $file" or die "Couldn't open file $file: $!";
 202   binmode F;
 203   print F $oldfile;
 204   close F;
 205   die "wrong length!" unless -s $file == $FLEN;
 206
 207   my @mt_args;
 208   my $expected = $oldfile;
 209   { my @a = @_;
 210     my $c = "a";
 211     while (@a) {
 212       my ($s, $len, $newlen) = splice @a, -3;
 213       my $newdata = $c++ x $newlen;
 214       substr($expected, $s, $len, $newdata);
 215       unshift @mt_args, $newdata, $s, $len;
 216     }
 217   }
 218
 219   my $o = tie my @lines, 'Tie::File', $file or die $!;
 220   my $actual_return = $o->_mtwrite(@mt_args);
 221   undef $o; untie @lines;
 222
 223   open F, "< $file" or die "Couldn't open file $file: $!";
 224   binmode F;
 225   my $actual;
 226   { local $/;
 227     $actual = <F>;
 228   }
 229   close F;
 230
 231   my ($alen, $xlen) = (length $actual, length $expected);
 232   unless ($alen == $xlen) {
 233     print "# try(@_) expected file length $xlen, actual $alen!\n";
 234   }
 235   print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
 236   $N++;
 237
 238 #  if (! defined $actual_return && ! defined $expected_return) {
 239 #    print "ok $N\n";
 240 #  } elsif (! defined $actual_return || ! defined $expected_return) {
 241 #    print "not ok $N\n";
 242 #  } else {
 243 #    print $actual_return eq $expected_return ? "ok $N\n" : "not ok $N\n";
 244 #  }
 245 #  $N++;
 246 }
 247
 248 sub try_all_doubles {
 249   print "# Trying double regions.\n";
 250   for my $a (@TRIES) {
 251     next if $a->[0] + $a->[1] >= $FLEN;
 252     next if $a->[0] + $a->[2] >= $FLEN;
 253     for my $b (@TRIES) {
 254       next if $b->[0] + $b->[1] >= $FLEN;
 255       next if $b->[0] + $b->[2] >= $FLEN;
 256
 257       next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions
 258       try(@$a, @$b);
 259     }
 260   }
 261 }
 262
 263 sub try_all_triples {
 264   print "# Trying triple regions.\n";
 265   for my $a (@BASE_TRIES) {
 266     next if $a->[0] + $a->[1] >= $FLEN;
 267     next if $a->[0] + $a->[2] >= $FLEN;
 268     for my $b (@BASE_TRIES) {
 269       next if $b->[0] + $b->[1] >= $FLEN;
 270       next if $b->[0] + $b->[2] >= $FLEN;
 271
 272       next if $b->[0] < $a->[0] + $a->[1]; # Overlapping regions
 273
 274       for my $c (@BASE_TRIES) {
 275         next if $c->[0] + $c->[1] >= $FLEN;
 276         next if $c->[0] + $c->[2] >= $FLEN;
 277
 278         next if $c->[0] < $b->[0] + $b->[1]; # Overlapping regions
 279         try(@$a, @$b, @$c);
 280       }
 281     }
 282   }
 283 }
 284
 285 sub ctrlfix {
 286   for (@_) {
 287     s/\n/\\n/g;
 288     s/\r/\\r/g;
 289   }
 290 }
 291
 292 END {
 293   1 while unlink $file;
 294 }
 295