Skip to content

Commit

Permalink
Initial commit
Browse files Browse the repository at this point in the history
  • Loading branch information
@uasi
uasi committed May 23, 2010
0 parents commit 3185d6d
Show file tree
Hide file tree
Showing 5 changed files with 328 additions and 0 deletions.
18 changes: 18 additions & 0 deletions Makefile
@@ -0,0 +1,18 @@
PERL = perl
PARROT_CONFIG = parrot_config
BIN_DIR = `$(PARROT_CONFIG) bindir`
LIB_DIR = `$(PARROT_CONFIG) libdir`
TOOLS_LIB_DIR = $(LIB_DIR)`$(PARROT_CONFIG) versiondir`/tools/lib

.PHONY: all test

all:

test:
$(PERL) -I$(TOOLS_LIB_DIR) t/harness --bindir=$(BIN_DIR)

# Local variables:
# mode: makefile
# End:
# vim: ft=make:

12 changes: 12 additions & 0 deletions lib/MessagePack.pm6
@@ -0,0 +1,12 @@
use v6;

module MessagePack;

use MessagePack::Unpacker;

sub unpack($str) {
MessagePack::Unpacker.unpack($str);
}

# vim: ft=perl6 :

179 changes: 179 additions & 0 deletions lib/MessagePack/Unpacker.pm6
@@ -0,0 +1,179 @@
use v6;

class MessagePack::Unpacker {
role Readable {
has $!pos = 0;

method read($bytes) {
fail if $!pos + $bytes > self.bytes;
my $s = self.substr($!pos, $bytes);
$!pos += $bytes;
$s;
}

method read-bytes($bytes) {
self.read($bytes).comb>>.ord;
}

method eos() {
$!pos == self.bytes;
}
}

has $!str;

my %unpack-for-type = (
0xc0 => { Nil },
0xc2 => { False },
0xc3 => { True },
0xca => { $_!unpack-float },
0xcb => { $_!unpack-double },
0xcc => { $_!unpack-uint8 },
0xcd => { $_!unpack-uint16 },
0xce => { $_!unpack-uint32 },
0xcf => { $_!unpack-uint64 },
0xd0 => { $_!unpack-int8 },
0xd1 => { $_!unpack-int16 },
0xd2 => { $_!unpack-int32 },
0xd3 => { $_!unpack-int64 },
0xda => { $_!unpack-raw( bytes => $_!unpack-uint16) },
0xdb => { $_!unpack-raw( bytes => $_!unpack-uint32) },
0xdc => { $_!unpack-array(elems => $_!unpack-uint16) },
0xdd => { $_!unpack-array(elems => $_!unpack-uint32) },
0xde => { $_!unpack-map( pairs => $_!unpack-uint16) },
0xdf => { $_!unpack-map( pairs => $_!unpack-uint32) },
);

submethod BUILD($str) {
$!str = $str but Readable;
}

method new($str) {
self.bless(*, :$str);
}

# Class method
method unpack($str) {
my $unpacker = self.new($str);
$unpacker!unpack;
}

method !unpack() {
my $type = self!unpack-uint8;

return (given $type {
when ($type +& 0b1000_0000) == 0b0000_0000 {
# positive fixnum
$type;
}
when ($type +& 0b1110_0000) == 0b1110_0000 {
# negative fixnum
($type +& 0b0001_1111) - 32;
}
when ($type +& 0b1110_0000) == 0b1010_0000 {
# fixraw
self!unpack-raw(bytes => $type +& 0b1_1111);
}
when ($type +& 0b1111_0000) == 0b1001_0000 {
# fixarray
self!unpack-array(elems => $type +& 0b1111);
}
when ($type +& 0b1111_0000) == 0b1000_0000 {
# fixmap
self!unpack-map(pairs => $type +& 0b1111);
}
when %unpack-for-type.exists($type) {
%unpack-for-type{$type}(self);
}
default {
fail sprintf("Unknown type 0x%02x", $type);
}
});
}

method !unpack-uint8() {
$!str.read-bytes(1)[0];
}

method !unpack-uint16() {
my @bytes = $!str.read-bytes(2);
(@bytes[0] +< 8) +|
(@bytes[1] );
}

method !unpack-uint32() {
my @bytes = $!str.read-bytes(4);
(@bytes[0] +< 24) +|
(@bytes[1] +< 16) +|
(@bytes[2] +< 8) +|
(@bytes[3] );
}

method !unpack-uint64() {
my @bytes = $!str.read-bytes(8);
(@bytes[0] +< 56) +|
(@bytes[1] +< 48) +|
(@bytes[2] +< 40) +|
(@bytes[3] +< 32) +|
(@bytes[4] +< 24) +|
(@bytes[5] +< 16) +|
(@bytes[6] +< 8) +|
(@bytes[7] );
}

method !unpack-int8() {
my $uint8 = self!unpack-uint8;
($uint8 < (1 +< 7)) ?? $uint8 !! $uint8 - (1 +< 8);
}

method !unpack-int16() {
my $uint16 = self!unpack-uint16;
($uint16 < (1 +< 15)) ?? $uint16 !! $uint16 - (1 +< 16);
}

method !unpack-int32() {
my $uint32 = self!unpack-uint32;
($uint32 < (1 +< 31)) ?? $uint32 !! $uint32 - (1 +< 32);
}

method !unpack-int64() {
my $uint64 = self!unpack-uint64;
($uint64 < (1 +< 15)) ?? $uint64 !! $uint64 - (1 +< 64);
}

method !unpack-float() {
my $v = self!unpack-uint32;
return 0.0 if $v == 0;

my $sign = $v +> 31 ?? -1 !! 1;
my $exp = (($v +> 23) +& 0xff) - 127;
my $frac = ($v +& 0x7f_ffff) +| 0x80_0000;
$sign * ($frac * 2 ** ($exp - 23));
}

method !unpack-double() {
my $hi = self!unpack-uint32;
my $lo = self!unpack-uint32;
return 0.0 if $hi == $lo == 0;

my $sign = $hi +> 31 ?? -1 !! 1;
my $exp = (($hi +> 20) +& 0x7ff) - 1023;
my $hfrac = ($hi +& 0xf_ffff) +| 0x10_0000;
$sign * (($hfrac * 2 ** ($exp - 20)) + 132 * ($lo * 2 ** ($exp - 52)));
}

method !unpack-raw($bytes) {
$!str.read($bytes);
}

method !unpack-array($elems) {
list(gather for ^$elems { take self!unpack });
}

method !unpack-map($pairs) {
hash(gather for ^$pairs { take self!unpack => self!unpack });
}
}

# vim: ft=perl6

94 changes: 94 additions & 0 deletions t/00-unpack.t
@@ -0,0 +1,94 @@
use v6;

use Test;
use MessagePack::Unpacker;

plan 61;

$_ = MessagePack::Unpacker;

is .unpack("\x00"), 0x00, q[positive fixnum];
is .unpack("\x7f"), 0x7f, q[positive fixnum];

is .unpack("\xff"), -0x01, q[negative fixnum];
is .unpack("\xe0"), -0x20, q[negative fixnum];

is .unpack("\xcc\x00"), 0x00, q[uint8];
is .unpack("\xcc\xff"), 0xff, q[uint8];

is .unpack("\xcd\x00\x00"), 0x0000, q[uint16];
is .unpack("\xcd\x00\x01"), 0x0001, q[uint16];
is .unpack("\xcd\xff\xff"), 0xffff, q[uint16];

is .unpack("\xce\x00\x00\x00\x00"), 0x0000_0000, q[uint32];
is .unpack("\xce\x00\x00\x00\x01"), 0x0000_0001, q[uint32];
is .unpack("\xce\xff\xff\xff\xff"), 0xffff_ffff, q[uint32];

is .unpack("\xcf" ~ "\x00" x 8 ), 0x0000_0000_0000_0000, q[uint64];
is .unpack("\xcf" ~ "\x00" x 7 ~ "\x01"), 0x0000_0000_0000_0001, q[uint64];
is .unpack("\xcf" ~ "\xff" x 8 ), 0xffff_ffff_ffff_ffff, q[uint64];

is .unpack("\xd0\x00"), 0x00, q[int8];
is .unpack("\xd0\x7f"), 0x7f, q[int8];
is .unpack("\xd0\xff"), -0x01, q[int8];
is .unpack("\xd0\x80"), -0x80, q[int8];

is .unpack("\xd1\x00\x00"), 0x0000, q[int16];
is .unpack("\xd1\x7f\xff"), 0x7fff, q[int16];
is .unpack("\xd1\xff\xff"), -0x0001, q[int16];
is .unpack("\xd1\x80\x00"), -0x8000, q[int16];

is .unpack("\xd2\x00\x00\x00\x00"), 0x0000_0000, q[int32];
is .unpack("\xd2\x7f\xff\xff\xff"), 0x7fff_ffff, q[int32];
is .unpack("\xd2\xff\xff\xff\xff"), -0x0000_0001, q[int32];
is .unpack("\xd2\x80\x00\x00\x00"), -0x8000_0000, q[int32];

is .unpack("\xd3" ~ "\x00" x 8), 0x0000_0000_0000_0000, q[int64];
is .unpack("\xd3\x7f" ~ "\xff" x 7), 0x7fff_ffff_ffff_ffff, q[int64];
is .unpack("\xd3" ~ "\xff" x 8), -0x0000_0000_0000_0001, q[int64];
is .unpack("\xd3\x80" ~ "\x00" x 7), -0x8000_0000_0000_0000, q[int64];

is .unpack("\xc0"), Nil, q[nil];
is .unpack("\xc2"), False, q[false];
is .unpack("\xc3"), True, q[true];

is .unpack("\xca\x00\x00\x00\x00"), 0.0, q[float];
is .unpack("\xca\x3f\x00\x00\x00"), 0.5, q[float];
is .unpack("\xca\xbf\x00\x00\x00"), -0.5, q[float];

is .unpack("\xcb\x00\x00\x00\x00\x00\x00\x00\x00"), 0.0, q[double];
is .unpack("\xcb\x3f\xe0\x00\x00\x00\x00\x00\x00"), 0.5, q[double];
is .unpack("\xcb\xbf\xe0\x00\x00\x00\x00\x00\x00"), -0.5, q[double];

is .unpack("\xa0" ~ "" ), "", q[fixraw];
is .unpack("\xa3" ~ "ABC" ), "ABC", q[fixfaw];
is .unpack("\xbf" ~ "A" x 31), "A" x 31, q[fixraw];

is .unpack("\xda\x00\x00" ~ "" ), "", q[raw16];
is .unpack("\xda\x00\x03" ~ "ABC" ), "ABC", q[raw16];
is .unpack("\xda\xff\xff" ~ "A" x 0xffff), "A" x 0xffff, q[raw16];

is .unpack("\xdb\x00\x00\x00\x00" ~ "" ), "", q[raw32];
is .unpack("\xdb\x00\x00\x00\x03" ~ "ABC" ), "ABC", q[raw32];
is .unpack("\xdb\x00\x01\x00\x00" ~ "A" x 0x1_0000), "A" x 0x1_0000, q[raw32];

is .unpack("\x90" ), [], q[fixarray];
is .unpack("\x93\x00\x01\x02"), [0, 1, 2], q[fixarray];

is .unpack("\xdc\x00\x00" ), [], q[array16];
is .unpack("\xdc\x00\x03\x00\x01\x02"), [0, 1, 2], q[array16];

is .unpack("\xdd\x00\x00\x00\x00" ), [], q[array32];
is .unpack("\xdd\x00\x00\x00\x03\x00\x01\x02"), [0, 1, 2], q[array32];

is .unpack("\x80" ), {}, q[fixmap];
is .unpack("\x82\x00\x01\x02\x03"), {0 => 1, 2 => 3}, q[fixmap];

is .unpack("\xde\x00\x00" ), {}, q[map16];
is .unpack("\xde\x00\x02\x00\x01\x02\x03"), {0 => 1, 2 => 3}, q[map16];

is .unpack("\xdf\x00\x00\x00\x00" ), {}, q[map32];
is .unpack("\xdf\x00\x00\x00\x02\x00\x01\x02\x03"), {0 => 1, 2 => 3}, q[map32];

# vim: ft=perl6 :

25 changes: 25 additions & 0 deletions t/harness
@@ -0,0 +1,25 @@
#!/usr/bin/env perl

use 5.008;
use strict;
use warnings;
use Getopt::Long;

my %harness_args = (
language => 'perl6',
jobs => $ENV{TEST_JOBS} || 1,
verbosity => 1,
merge => 0,
);

GetOptions(
'verbosity=i' => \$harness_args{verbosity},
'bindir=s' => \my $bindir,
'jobs:3' => \$harness_args{jobs},
);


$harness_args{exec} = [$bindir . '/perl6'];

eval 'use Parrot::Test::Harness %harness_args';

0 comments on commit 3185d6d

Please sign in to comment.