dist/Tie-File/t/26_twrite.t

   1 #!/usr/bin/perl
   2 #
   3 # Unit tests of _twrite function
   4 #
   5 # _twrite($self, $data, $pos, $len)
   6 #
   7 # 't' here is for 'tail'.  This writes $data at absolute position $pos
   8 # in the file, overwriting exactly $len of the bytes at that position.
   9 # Everything else is moved down or up, dependong on whether
  10 # length($data) > $len or length($data) < $len.
  11 # $len == 0 is a pure insert; $len == length($data) is a simple overwrite.
  12 #
  13
  14 my $file = "tf$$.txt";
  15
  16 print "1..181\n";
  17
  18 my $N = 1;
  19 use Tie::File;
  20 print "ok $N\n"; $N++;
  21
  22 $: = Tie::File::_default_recsep();
  23
  24 # (2) Peter Scott sent this one.  It fails in 0.51 and works in 0.90
  25 # <4.3.2.7.2.20020331102819.00b913d0@shell2.webquarry.com>
  26 #
  27 # The problem was premature termination in the inner loop
  28 # because you had $more_data scoped *inside* the block instead of outside.
  29 # 20020331
  30 open F, "> $file" or die "Couldn't open $file: $!";
  31 binmode F;
  32 for (1..100) {
  33   print F "$_ ", 'a'x150, $: ;
  34 }
  35 close F;
  36 # The file is now 15292 characters long on Unix, 15392 on Win32
  37 die -s $file unless -s $file == 15292 + 100 * length($:);
  38
  39 tie my @lines, 'Tie::File', $file or die $!;
  40 push @lines, "1001 ".('a' x 100);
  41 splice @lines, 0, 1;
  42 untie @lines;
  43
  44 my $s = -s $file;
  45 my $x = 15292 - 152 + 105 + 100*length($:);
  46 print $s == $x
  47   ? "ok $N\n" : "not ok $N # expected $x, got $s\n";
  48 $N++;
  49
  50 my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
  51
  52 # (3-73) These were generated by 'gentests.pl' to cover all possible cases
  53 # (I hope)
  54 # Legend:
  55 #         x: data is entirely contained within one block
  56 #        x>: data runs from the middle to the end of the block
  57 #        <x: data runs from the start to the middle of the block
  58 #       <x>: data occupies precisely one block
  59 #      x><x: data overlaps one block boundary
  60 #     <x><x: data runs from the start of one block into the middle of the next
  61 #     x><x>: data runs from the middle of one block to the end of the next
  62 #    <x><x>: data occupies two blocks exactly
  63 # <x><x><x>: data occupies three blocks exactly
  64 #         0: data is null
  65 #
  66 # For each possible alignment of the old and new data, we investigate
  67 # up to three situations: old data is shorter, old and new data are the
  68 # same length, and new data is shorter.
  69 #
  70 # try($pos, $old, $new) means to run a test where the data starts at
  71 # position $pos, the old data has length $old,
  72 # and the new data has length $new.
  73 try( 9659,  6635,  6691);  # old=x        , new=x        ; old < new
  74 try( 8605,  2394,  2394);  # old=x        , new=x        ; old = new
  75 try( 9768,  1361,   664);  # old=x        , new=x        ; old > new
  76 try( 9955,  6429,  6429);  # old=x>       , new=x        ; old = new
  77 try(10550,  5834,  4123);  # old=x>       , new=x        ; old > new
  78 try(14580,  6158,   851);  # old=x><x     , new=x        ; old > new
  79 try(13442, 11134,  1572);  # old=x><x>    , new=x        ; old > new
  80 try( 8394,     0,  5742);  # old=0        , new=x        ; old < new
  81 try( 8192,  2819,  6738);  # old=<x       , new=<x       ; old < new
  82 try( 8192,   514,   514);  # old=<x       , new=<x       ; old = new
  83 try( 8192,  2196,   858);  # old=<x       , new=<x       ; old > new
  84 try( 8192,  8192,  8192);  # old=<x>      , new=<x       ; old = new
  85 try( 8192,  8192,  1290);  # old=<x>      , new=<x       ; old > new
  86 try( 8192, 10575,  6644);  # old=<x><x    , new=<x       ; old > new
  87 try( 8192, 16384,  5616);  # old=<x><x>   , new=<x       ; old > new
  88 try( 8192, 24576,  6253);  # old=<x><x><x>, new=<x       ; old > new
  89 try( 8192,     0,  6870);  # old=0        , new=<x       ; old < new
  90 try( 8478,  6259,  7906);  # old=x        , new=x>       ; old < new
  91 try( 9965,  6419,  6419);  # old=x>       , new=x>       ; old = new
  92 try(16059,  6102,   325);  # old=x><x     , new=x>       ; old > new
  93 try( 9503, 15073,  6881);  # old=x><x>    , new=x>       ; old > new
  94 try( 9759,     0,  6625);  # old=0        , new=x>       ; old < new
  95 try( 8525,  2081,  8534);  # old=x        , new=x><x     ; old < new
  96 try(15550,   834,  1428);  # old=x>       , new=x><x     ; old < new
  97 try(14966,  1668,  3479);  # old=x><x     , new=x><x     ; old < new
  98 try(16316,  1605,  1605);  # old=x><x     , new=x><x     ; old = new
  99 try(16093,  4074,   993);  # old=x><x     , new=x><x     ; old > new
 100 try(14739,  9837,  9837);  # old=x><x>    , new=x><x     ; old = new
 101 try(14071, 10505,  7344);  # old=x><x>    , new=x><x     ; old > new
 102 try(12602,     0,  8354);  # old=0        , new=x><x     ; old < new
 103 try( 8192,  2767,  8192);  # old=<x       , new=<x>      ; old < new
 104 try( 8192,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
 105 try( 8192, 14817,  8192);  # old=<x><x    , new=<x>      ; old > new
 106 try( 8192, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
 107 try( 8192, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
 108 try( 8192,     0,  8192);  # old=0        , new=<x>      ; old < new
 109 try( 8192,  6532, 10882);  # old=<x       , new=<x><x    ; old < new
 110 try( 8192,  8192, 16044);  # old=<x>      , new=<x><x    ; old < new
 111 try( 8192,  9555, 11020);  # old=<x><x    , new=<x><x    ; old < new
 112 try( 8192,  9001,  9001);  # old=<x><x    , new=<x><x    ; old = new
 113 try( 8192, 11760, 10274);  # old=<x><x    , new=<x><x    ; old > new
 114 try( 8192, 16384, 10781);  # old=<x><x>   , new=<x><x    ; old > new
 115 try( 8192, 24576,  9284);  # old=<x><x><x>, new=<x><x    ; old > new
 116 try( 8192,     0, 12488);  # old=0        , new=<x><x    ; old < new
 117 try( 8222,  6385, 16354);  # old=x        , new=x><x>    ; old < new
 118 try(13500,  2884, 11076);  # old=x>       , new=x><x>    ; old < new
 119 try(14069,  4334, 10507);  # old=x><x     , new=x><x>    ; old < new
 120 try(14761,  9815,  9815);  # old=x><x>    , new=x><x>    ; old = new
 121 try(10469,     0, 14107);  # old=0        , new=x><x>    ; old < new
 122 try( 8192,  4181, 16384);  # old=<x       , new=<x><x>   ; old < new
 123 try( 8192,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
 124 try( 8192, 12087, 16384);  # old=<x><x    , new=<x><x>   ; old < new
 125 try( 8192, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
 126 try( 8192, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
 127 try( 8192,     0, 16384);  # old=0        , new=<x><x>   ; old < new
 128 try( 8192,  4968, 24576);  # old=<x       , new=<x><x><x>; old < new
 129 try( 8192,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
 130 try( 8192, 14163, 24576);  # old=<x><x    , new=<x><x><x>; old < new
 131 try( 8192, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
 132 try( 8192, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
 133 try( 8192,     0, 24576);  # old=0        , new=<x><x><x>; old < new
 134 try( 8771,   776,     0);  # old=x        , new=0        ; old > new
 135 try( 8192,  2813,     0);  # old=<x       , new=0        ; old > new
 136 try(13945,  2439,     0);  # old=x>       , new=0        ; old > new
 137 try(14493,  6090,     0);  # old=x><x     , new=0        ; old > new
 138 try( 8192,  8192,     0);  # old=<x>      , new=0        ; old > new
 139 try( 8192, 10030,     0);  # old=<x><x    , new=0        ; old > new
 140 try(14983,  9593,     0);  # old=x><x>    , new=0        ; old > new
 141 try( 8192, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 142 try( 8192, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 143 try(10489,     0,     0);  # old=0        , new=0        ; old = new
 144
 145 # (74-114)
 146 # These tests all take place at the start of the file
 147 try(    0,   771,  1593);  # old=<x       , new=<x       ; old < new
 148 try(    0,  4868,  4868);  # old=<x       , new=<x       ; old = new
 149 try(    0,   147,   118);  # old=<x       , new=<x       ; old > new
 150 try(    0,  8192,  8192);  # old=<x>      , new=<x       ; old = new
 151 try(    0,  8192,  4574);  # old=<x>      , new=<x       ; old > new
 152 try(    0, 11891,  1917);  # old=<x><x    , new=<x       ; old > new
 153 try(    0, 16384,  5155);  # old=<x><x>   , new=<x       ; old > new
 154 try(    0, 24576,  2953);  # old=<x><x><x>, new=<x       ; old > new
 155 try(    0,     0,  1317);  # old=0        , new=<x       ; old < new
 156 try(    0,  5609,  8192);  # old=<x       , new=<x>      ; old < new
 157 try(    0,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
 158 try(    0, 11083,  8192);  # old=<x><x    , new=<x>      ; old > new
 159 try(    0, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
 160 try(    0, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
 161 try(    0,     0,  8192);  # old=0        , new=<x>      ; old < new
 162 try(    0,  6265,  9991);  # old=<x       , new=<x><x    ; old < new
 163 try(    0,  8192, 16119);  # old=<x>      , new=<x><x    ; old < new
 164 try(    0, 10218, 11888);  # old=<x><x    , new=<x><x    ; old < new
 165 try(    0, 14126, 14126);  # old=<x><x    , new=<x><x    ; old = new
 166 try(    0, 12002,  9034);  # old=<x><x    , new=<x><x    ; old > new
 167 try(    0, 16384, 13258);  # old=<x><x>   , new=<x><x    ; old > new
 168 try(    0, 24576, 14367);  # old=<x><x><x>, new=<x><x    ; old > new
 169 try(    0,     0, 10881);  # old=0        , new=<x><x    ; old < new
 170 try(    0,  6448, 16384);  # old=<x       , new=<x><x>   ; old < new
 171 try(    0,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
 172 try(    0, 15082, 16384);  # old=<x><x    , new=<x><x>   ; old < new
 173 try(    0, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
 174 try(    0, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
 175 try(    0,     0, 16384);  # old=0        , new=<x><x>   ; old < new
 176 try(    0,  2421, 24576);  # old=<x       , new=<x><x><x>; old < new
 177 try(    0,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
 178 try(    0, 11655, 24576);  # old=<x><x    , new=<x><x><x>; old < new
 179 try(    0, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
 180 try(    0, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
 181 try(    0,     0, 24576);  # old=0        , new=<x><x><x>; old < new
 182 try(    0,  6530,     0);  # old=<x       , new=0        ; old > new
 183 try(    0,  8192,     0);  # old=<x>      , new=0        ; old > new
 184 try(    0, 14707,     0);  # old=<x><x    , new=0        ; old > new
 185 try(    0, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 186 try(    0, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 187 try(    0,     0,     0);  # old=0        , new=0        ; old = new
 188
 189 # (115-141)
 190 # These tests all take place at the end of the file
 191 $FLEN = 40960;  # Force the file to be exactly 40960 bytes long
 192 try(32768,  8192,  8192);  # old=<x>      , new=<x       ; old = new
 193 try(32768,  8192,  4026);  # old=<x>      , new=<x       ; old > new
 194 try(24576, 16384,  1917);  # old=<x><x>   , new=<x       ; old > new
 195 try(16384, 24576,  3818);  # old=<x><x><x>, new=<x       ; old > new
 196 try(40960,     0,  2779);  # old=0        , new=<x       ; old < new
 197 try(32768,  8192,  8192);  # old=<x>      , new=<x>      ; old = new
 198 try(24576, 16384,  8192);  # old=<x><x>   , new=<x>      ; old > new
 199 try(16384, 24576,  8192);  # old=<x><x><x>, new=<x>      ; old > new
 200 try(40960,     0,  8192);  # old=0        , new=<x>      ; old < new
 201 try(32768,  8192, 10724);  # old=<x>      , new=<x><x    ; old < new
 202 try(24576, 16384, 12221);  # old=<x><x>   , new=<x><x    ; old > new
 203 try(16384, 24576, 15030);  # old=<x><x><x>, new=<x><x    ; old > new
 204 try(40960,     0, 11752);  # old=0        , new=<x><x    ; old < new
 205 try(32768,  8192, 16384);  # old=<x>      , new=<x><x>   ; old < new
 206 try(24576, 16384, 16384);  # old=<x><x>   , new=<x><x>   ; old = new
 207 try(16384, 24576, 16384);  # old=<x><x><x>, new=<x><x>   ; old > new
 208 try(40960,     0, 16384);  # old=0        , new=<x><x>   ; old < new
 209 try(32768,  8192, 24576);  # old=<x>      , new=<x><x><x>; old < new
 210 try(24576, 16384, 24576);  # old=<x><x>   , new=<x><x><x>; old < new
 211 try(16384, 24576, 24576);  # old=<x><x><x>, new=<x><x><x>; old = new
 212 try(40960,     0, 24576);  # old=0        , new=<x><x><x>; old < new
 213 try(35973,  4987,     0);  # old=x>       , new=0        ; old > new
 214 try(32768,  8192,     0);  # old=<x>      , new=0        ; old > new
 215 try(29932, 11028,     0);  # old=x><x>    , new=0        ; old > new
 216 try(24576, 16384,     0);  # old=<x><x>   , new=0        ; old > new
 217 try(16384, 24576,     0);  # old=<x><x><x>, new=0        ; old > new
 218 try(40960,     0,     0);  # old=0        , new=0        ; old = new
 219
 220 # (142-181)
 221 # These tests all take place at the end of the file
 222 $FLEN = 42000;  # Force the file to be exactly 42000 bytes long
 223 try(41275,   725,  4059);  # old=x        , new=x        ; old < new
 224 try(41683,   317,   317);  # old=x        , new=x        ; old = new
 225 try(41225,   775,   405);  # old=x        , new=x        ; old > new
 226 try(35709,  6291,   284);  # old=x><x     , new=x        ; old > new
 227 try(42000,     0,  2434);  # old=0        , new=x        ; old < new
 228 try(40960,  1040,  1608);  # old=<x       , new=<x       ; old < new
 229 try(40960,  1040,  1040);  # old=<x       , new=<x       ; old = new
 230 try(40960,  1040,   378);  # old=<x       , new=<x       ; old > new
 231 try(32768,  9232,  5604);  # old=<x><x    , new=<x       ; old > new
 232 try(42000,     0,  6637);  # old=0        , new=<x       ; old < new
 233 try(41022,   978,  8130);  # old=x        , new=x>       ; old < new
 234 try(39994,  2006,   966);  # old=x><x     , new=x>       ; old > new
 235 try(42000,     0,  7152);  # old=0        , new=x>       ; old < new
 236 try(41613,   387, 10601);  # old=x        , new=x><x     ; old < new
 237 try(38460,  3540,  3938);  # old=x><x     , new=x><x     ; old < new
 238 try(36725,  5275,  5275);  # old=x><x     , new=x><x     ; old = new
 239 try(37990,  4010,  3199);  # old=x><x     , new=x><x     ; old > new
 240 try(42000,     0,  9189);  # old=0        , new=x><x     ; old < new
 241 try(40960,  1040,  8192);  # old=<x       , new=<x>      ; old < new
 242 try(32768,  9232,  8192);  # old=<x><x    , new=<x>      ; old > new
 243 try(42000,     0,  8192);  # old=0        , new=<x>      ; old < new
 244 try(40960,  1040, 11778);  # old=<x       , new=<x><x    ; old < new
 245 try(32768,  9232, 13792);  # old=<x><x    , new=<x><x    ; old < new
 246 try(32768,  9232,  9232);  # old=<x><x    , new=<x><x    ; old = new
 247 try(32768,  9232,  8795);  # old=<x><x    , new=<x><x    ; old > new
 248 try(42000,     0,  8578);  # old=0        , new=<x><x    ; old < new
 249 try(41531,   469, 15813);  # old=x        , new=x><x>    ; old < new
 250 try(39618,  2382,  9534);  # old=x><x     , new=x><x>    ; old < new
 251 try(42000,     0, 15344);  # old=0        , new=x><x>    ; old < new
 252 try(40960,  1040, 16384);  # old=<x       , new=<x><x>   ; old < new
 253 try(32768,  9232, 16384);  # old=<x><x    , new=<x><x>   ; old < new
 254 try(42000,     0, 16384);  # old=0        , new=<x><x>   ; old < new
 255 try(40960,  1040, 24576);  # old=<x       , new=<x><x><x>; old < new
 256 try(32768,  9232, 24576);  # old=<x><x    , new=<x><x><x>; old < new
 257 try(42000,     0, 24576);  # old=0        , new=<x><x><x>; old < new
 258 try(41500,   500,     0);  # old=x        , new=0        ; old > new
 259 try(40960,  1040,     0);  # old=<x       , new=0        ; old > new
 260 try(35272,  6728,     0);  # old=x><x     , new=0        ; old > new
 261 try(32768,  9232,     0);  # old=<x><x    , new=0        ; old > new
 262 try(42000,     0,     0);  # old=0        , new=0        ; old = new
 263
 264 sub try {
 265   my ($pos, $len, $newlen) = @_;
 266   open F, "> $file" or die "Couldn't open file $file: $!";
 267   binmode F;
 268
 269   # The record has exactly 17 characters.  This will help ensure that
 270   # even if _twrite screws up, the data doesn't coincidentally
 271   # look good because the remainder accidentally lines up.
 272   my $d = substr("0123456789abcdef$:", -17);
 273   my $recs = defined($FLEN) ?
 274     int($FLEN/length($d))+1 : # enough to make up at least $FLEN
 275     int(8192*5/length($d))+1; # at least 5 blocks' worth
 276   my $oldfile = $d x $recs;
 277   my $flen = defined($FLEN) ? $FLEN : $recs * 17;
 278   substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
 279   print F $oldfile;
 280   close F;
 281
 282   die "wrong length!" unless -s $file == $flen;
 283
 284   my $newdata = "-" x $newlen;
 285   my $expected = $oldfile;
 286   substr($expected, $pos, $len) = $newdata;
 287
 288   my $o = tie my @lines, 'Tie::File', $file or die $!;
 289   $o->_twrite($newdata, $pos, $len);
 290   undef $o; untie @lines;
 291
 292   open F, "< $file" or die "Couldn't open file $file: $!";
 293   binmode F;
 294   my $actual;
 295   { local $/;
 296     $actual = <F>;
 297   }
 298   close F;
 299
 300   my ($alen, $xlen) = (length $actual, length $expected);
 301   unless ($alen == $xlen) {
 302     print "# try(@_) expected file length $xlen, actual $alen!\n";
 303   }
 304   print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
 305   $N++;
 306 }
 307
 308
 309
 310 use POSIX 'SEEK_SET';
 311 sub check_contents {
 312   my @c = @_;
 313   my $x = join $:, @c, '';
 314   local *FH = $o->{fh};
 315   seek FH, 0, SEEK_SET;
 316 #  my $open = open FH, "< $file";
 317   my $a;
 318   { local $/; $a = <FH> }
 319   $a = "" unless defined $a;
 320   if ($a eq $x) {
 321     print "ok $N\n";
 322   } else {
 323     ctrlfix($a, $x);
 324     print "not ok $N\n# expected <$x>, got <$a>\n";
 325   }
 326   $N++;
 327
 328   # now check FETCH:
 329   my $good = 1;
 330   my $msg;
 331   for (0.. $#c) {
 332     my $aa = $a[$_];
 333     unless ($aa eq "$c[$_]$:") {
 334       $msg = "expected <$c[$_]$:>, got <$aa>";
 335       ctrlfix($msg);
 336       $good = 0;
 337     }
 338   }
 339   print $good ? "ok $N\n" : "not ok $N # $msg\n";
 340   $N++;
 341
 342   print $o->_check_integrity($file, $ENV{INTEGRITY})
 343       ? "ok $N\n" : "not ok $N\n";
 344   $N++;
 345 }
 346
 347 sub ctrlfix {
 348   for (@_) {
 349     s/\n/\\n/g;
 350     s/\r/\\r/g;
 351   }
 352 }
 353
 354 END {
 355   undef $o;
 356   untie @a;
 357   1 while unlink $file;
 358 }
 359