t/lib-chunk/corrupt-chunk-file.pl

   1 #!/usr/bin/perl
   2
   3 my ($chunk, $seek, $bytes) = @ARGV;
   4 $bytes =~ s/../chr(hex($&))/ge;
   5
   6 binmode STDIN;
   7 binmode STDOUT;
   8
   9 # A few helpers to read bytes, or read and copy them to the
  10 # output.
  11 sub get {
  12         my $n = shift;
  13         return unless $n;
  14         read(STDIN, my $buf, $n)
  15                 or die "read error or eof: $!\n";
  16         return $buf;
  17 }
  18 sub copy {
  19         my $buf = get(@_);
  20         print $buf;
  21         return $buf;
  22 }
  23
  24 # Some platforms' perl builds don't support 64-bit integers, and hence do not
  25 # allow packing/unpacking quadwords with "Q". The chunk format uses 64-bit file
  26 # offsets to support files of any size, but in practice our test suite will
  27 # only use small files. So we can fake it by asking for two 32-bit values and
  28 # discarding the first (most significant) one, which is equivalent as long as
  29 # it's just zero.
  30 sub unpack_quad {
  31         my $bytes = shift;
  32         my ($n1, $n2) = unpack("NN", $bytes);
  33         die "quad value exceeds 32 bits" if $n1;
  34         return $n2;
  35 }
  36 sub pack_quad {
  37         my $n = shift;
  38         my $ret = pack("NN", 0, $n);
  39         # double check that our original $n did not exceed the 32-bit limit.
  40         # This is presumably impossible on a 32-bit system (which would have
  41         # truncated much earlier), but would still alert us on a 64-bit build
  42         # of a new test that would fail on a 32-bit build (though we'd
  43         # presumably see the die() from unpack_quad() in such a case).
  44         die "quad round-trip failed" if unpack_quad($ret) != $n;
  45         return $ret;
  46 }
  47
  48 # read until we find table-of-contents entry for chunk;
  49 # note that we cheat a bit by assuming 4-byte alignment and
  50 # that no ToC entry will accidentally look like a header.
  51 #
  52 # If we don't find the entry, copy() will hit EOF and exit
  53 # (which should cause the caller to fail the test).
  54 while (copy(4) ne $chunk) { }
  55 my $offset = unpack_quad(copy(8));
  56
  57 # In clear mode, our length will change. So figure out
  58 # the length by comparing to the offset of the next chunk, and
  59 # then adjust that offset (and all subsequent) ones.
  60 my $len;
  61 if ($seek eq "clear") {
  62         my $id;
  63         do {
  64                 $id = copy(4);
  65                 my $next = unpack_quad(get(8));
  66                 if (!defined $len) {
  67                         $len = $next - $offset;
  68                 }
  69                 print pack_quad($next - $len + length($bytes));
  70         } while (unpack("N", $id));
  71 }
  72
  73 # and now copy up to our existing chunk data
  74 copy($offset - tell(STDIN));
  75 if ($seek eq "clear") {
  76         # if clearing, skip past existing data
  77         get($len);
  78 } else {
  79         # otherwise, copy up to the requested offset,
  80         # and skip past the overwritten bytes
  81         copy($seek);
  82         get(length($bytes));
  83 }
  84
  85 # now write out the requested bytes, along
  86 # with any other remaining data
  87 print $bytes;
  88 while (read(STDIN, my $buf, 4096)) {
  89         print $buf;
  90 }