Binary decoding

gif-grammar.p6

# What about encoding back?
# grammar Image::GIF::Grammar {
class Image::GIF::Decoder is Decoder {
    token TOP {
        :my $*CT-valid; # set in lexical <packed>
        :my $*CT-size;  # also set in <packed>
        <header>
        <screen>
        <color-table>?
        <labeled>*
        <terminator>
    }
    token header { GIF $<ver>=[87a|89a] }
    token screen {
        <width=.double> # double predefined
        <height=.double>
        <packed> # ??? (bits)
        <bg-color-idx=uint>
        <px-aspect-ratio=uint>
    }
    token color-table { <{$*CT-valid}> <uint> ** {3 * $*CT-size} }
    token sub-block {
        $<n> = .
        . ** {+$<n>}
    }
    token extention { '!' } # Check if valid ver?
    proto token labeled {*}
    token labeled:comment     { <extention> \xFE <sub-block> }
    token labeled:application { <extention> \xFF <sub-block> }
    token labeled:plain-text  { <extention> \x01 <sub-block> }
    token labeled:graphic     { <extention> \xF9 <sub-block> }

    token labeled:image {
        ','
        :my $*CT-valid;
        :my $*CT-size;
        <left=double>
        <top=double>
        <width=double>
        <height=double>
        <packed> # :/ (bits)
        <color-table>?
        <sub-block>
    }
    token terminator { ';' }
}

class Image::GIF::Decoder::Actions {
    method TOP ($/){
        # This is going to pass a *lot* of data
        # to a single .new call
        Image::GIF.new:
            |$<screen>,
            color-table => $<color-table>.ast,
            |$<labeled>.».ast
    }
    # method color-table { ... }
    # method labeled:* { ... }
}

method !decode-gif (Buf $b --> Image::GIF) {
    Image::GIF::Decoder.decode:
    # OR Image::GIF::Decoder.parse:
        $b, :actions(Image::GIF::Decoder::Actions);
}

gif-now.p6

# N.B.: This perhaps should use unpack in many places it doesn't,
# and almost tries to replace unpack with &term:<get> and &term:<sub-block>.
#
# Maybe that's not a bad thing…
method !decode-gif (Buf $b --> Image::GIF) {
    my $pos = -1;
    my sub term:<get> () { $b[++$pos] }
    my sub term:<sub-block> () { my$n=get; get xx $n; $n }
    my &bad-gif = ->$p?{
        X::Image::GIF::Malformed.new(:pos($p // $pos)).fail;
    }

    # Header
    chrs(get xx 3) eq "GIF" or bad-gif;
    ($!ver = chrs get xx 3) eq "87a"|"89a"
        or X::Image::GIF::Unknown.new(:version($!ver)).throw;

    # Logical Screen Descriptor
    $!width = get + get+<8;
    $!height = get + get+<8;
    my $gct-exists; # Do we have a global color table?
    my $gct-size; # How big is it?
    do {
        # <Packed Fields>
        my @packed = get.base(2).fmt("%08d").comb;
        $gct-exists = @packed[0];
        $!color-resolution = :2(@packed[1..3].join);
        # Skip @packed[4] -- we don't need to know
        $gct-size = 2**(:2(@packed[5..7].join) + 1);
    }
    $!bg-color-idx = get;
    $!px-aspect-ratio = get;

    # Global Color Table
    if $gct-exists {
        @!color-table.push: (get*16**2 + get*16 + get).fmt("%06X")
            for ^$gct-size;
    }

    # Labeled blocks
    my $gce = False; # Was the last block a Graphic Control Extention
    loop { given get {
        when $.ver ge "89a" && 0x21 { # Extention
            given get {
                when 0xFE { # Comment
                    repeat {} while sub-block;
                }
                when 0xFF { # Application
                    sub-block;
                    repeat {} while sub-block;
                }
                when 0x01 { # Plain Text, no point supporting
                    sub-block;
                    repeat {} while sub-block;
                }
                when 0xF9 { # Graphic Control
                    $gce = True;
                    @!data[+*] //= Image::GIF::Block.new;
                    get;
                    my @packed = get.base(2).fmt("%08d").comb;
                    @!data[*-1].disposal-method = :2(@packed[3..5].join);
                    @!data[*-1].user-input = @packed[6];
                    @!data[*-1].delay = get+<8 + get;
                    @!data[*-1].transparency-idx = @packed[7] * get;
                    get != 0 and bad-gif;
                }
            }
        }
        when 0x2C { # Image Descriptor
            @!data[$gce ?? *-1 !! +*] //= Image::GIF::Block.new;
            @!data[*-1].left = get + get+<8;
            @!data[*-1].top = get + get+<8;
            @!data[*-1].width = get + get+<8;
            @!data[*-1].height = get + get+<8;
            my @packed = get.base(2).fmt("%08d").comb;
            # Local Color Table
            if @packed[0] {
                @!data[*-1].color-table.push: (get*16**2 + get*16 + get).fmt("%06X")
                    for ^2**(:2(@packed[5..7].join)+1);
            }
            my $init-code-size = get;
            my %enc;
            my @bytes = gather while get -> $_ {
                for ^$_ {
                    get.base(2).fmt("%08d").comb.».take
                }
            }
            $gce = False;
        }
        when 0x3B { # Trailer
            last
        }
        default { note "$pos -- $b[$pos]"; bad-gif }
    }}

    self;
}