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