LMXF-specification/tools/LXMF/MessagePack.pm

package LXMF::MessagePack;

use strict;
use warnings;
use Exporter 'import';

our @EXPORT_OK = qw(
    pack_array
    pack_bin
    pack_float64
    pack_map
    parse_item
);

sub pack_float64 {
    my ($value) = @_;
    return "\xcb" . pack("d>", $value);
}

sub pack_bin {
    my ($value) = @_;
    my $length = length($value);

    return "\xc4" . pack("C", $length) . $value if $length <= 0xff;
    return "\xc5" . pack("n", $length) . $value if $length <= 0xffff;
    return "\xc6" . pack("N", $length) . $value;
}

sub pack_array {
    my (@items) = @_;
    my $length = scalar @items;
    my $header;

    if ($length <= 15) {
        $header = pack("C", 0x90 | $length);
    }
    elsif ($length <= 0xffff) {
        $header = "\xdc" . pack("n", $length);
    }
    else {
        $header = "\xdd" . pack("N", $length);
    }

    return $header . join("", @items);
}

sub pack_map {
    my (@entries) = @_;
    die "pack_map requires key/value byte-string pairs\n" if @entries % 2;

    my $length = @entries / 2;
    my $header;

    if ($length <= 15) {
        $header = pack("C", 0x80 | $length);
    }
    elsif ($length <= 0xffff) {
        $header = "\xde" . pack("n", $length);
    }
    else {
        $header = "\xdf" . pack("N", $length);
    }

    return $header . join("", @entries);
}

sub _take {
    my ($bytes, $offset_ref, $length) = @_;
    die "truncated MessagePack item\n" if $$offset_ref + $length > length($bytes);
    my $value = substr($bytes, $$offset_ref, $length);
    $$offset_ref += $length;
    return $value;
}

sub _parse_length {
    my ($bytes, $offset_ref, $width) = @_;
    my $raw = _take($bytes, $offset_ref, $width);
    return unpack("C", $raw) if $width == 1;
    return unpack("n", $raw) if $width == 2;
    return unpack("N", $raw);
}

sub parse_item {
    my ($bytes, $offset_ref) = @_;
    $offset_ref //= \my $offset;
    $$offset_ref //= 0;

    my $start = $$offset_ref;
    my $code = unpack("C", _take($bytes, $offset_ref, 1));
    my $item = { code => $code };

    if ($code <= 0x7f) {
        @$item{qw(type value)} = ("integer", $code);
    }
    elsif ($code >= 0xe0) {
        @$item{qw(type value)} = ("integer", $code - 256);
    }
    elsif (($code & 0xf0) == 0x90) {
        _parse_array($bytes, $offset_ref, $item, $code & 0x0f);
    }
    elsif (($code & 0xf0) == 0x80) {
        _parse_map($bytes, $offset_ref, $item, $code & 0x0f);
    }
    elsif (($code & 0xe0) == 0xa0) {
        my $length = $code & 0x1f;
        @$item{qw(type value)} = ("string", _take($bytes, $offset_ref, $length));
    }
    elsif ($code == 0xc0) {
        $item->{type} = "nil";
        $item->{value} = undef;
    }
    elsif ($code == 0xc2 || $code == 0xc3) {
        @$item{qw(type value)} = ("boolean", $code == 0xc3 ? 1 : 0);
    }
    elsif ($code == 0xca) {
        @$item{qw(type value)} = ("float32", unpack("f>", _take($bytes, $offset_ref, 4)));
    }
    elsif ($code == 0xcb) {
        @$item{qw(type value)} = ("float64", unpack("d>", _take($bytes, $offset_ref, 8)));
    }
    elsif ($code >= 0xc4 && $code <= 0xc6) {
        my $width = 1 << ($code - 0xc4);
        my $length = _parse_length($bytes, $offset_ref, $width);
        @$item{qw(type value)} = ("binary", _take($bytes, $offset_ref, $length));
    }
    elsif ($code >= 0xcc && $code <= 0xcf) {
        my @formats = ("C", "n", "N", "Q>");
        my @widths = (1, 2, 4, 8);
        my $index = $code - 0xcc;
        @$item{qw(type value)} = (
            "integer",
            unpack($formats[$index], _take($bytes, $offset_ref, $widths[$index])),
        );
    }
    elsif ($code >= 0xd0 && $code <= 0xd3) {
        my @formats = ("c", "s>", "l>", "q>");
        my @widths = (1, 2, 4, 8);
        my $index = $code - 0xd0;
        @$item{qw(type value)} = (
            "integer",
            unpack($formats[$index], _take($bytes, $offset_ref, $widths[$index])),
        );
    }
    elsif ($code == 0xd9 || $code == 0xda || $code == 0xdb) {
        my $width = 1 << ($code - 0xd9);
        my $length = _parse_length($bytes, $offset_ref, $width);
        @$item{qw(type value)} = ("string", _take($bytes, $offset_ref, $length));
    }
    elsif ($code == 0xdc || $code == 0xdd) {
        my $width = $code == 0xdc ? 2 : 4;
        _parse_array($bytes, $offset_ref, $item, _parse_length($bytes, $offset_ref, $width));
    }
    elsif ($code == 0xde || $code == 0xdf) {
        my $width = $code == 0xde ? 2 : 4;
        _parse_map($bytes, $offset_ref, $item, _parse_length($bytes, $offset_ref, $width));
    }
    else {
        die sprintf("unsupported MessagePack code 0x%02x at offset %d\n", $code, $start);
    }

    $item->{start} = $start;
    $item->{end} = $$offset_ref;
    $item->{raw} = substr($bytes, $start, $$offset_ref - $start);
    return $item;
}

sub _parse_array {
    my ($bytes, $offset_ref, $item, $length) = @_;
    $item->{type} = "array";
    $item->{items} = [map { parse_item($bytes, $offset_ref) } 1 .. $length];
}

sub _parse_map {
    my ($bytes, $offset_ref, $item, $length) = @_;
    $item->{type} = "map";
    $item->{entries} = [
        map { [parse_item($bytes, $offset_ref), parse_item($bytes, $offset_ref)] } 1 .. $length
    ];
}

1;