PP.pm

package Data::MessagePack::PP;
use 5.008001;
use strict;
use warnings;
no warnings 'recursion';

use Carp ();
use B ();
use Config;

# See also
# http://redmine.msgpack.org/projects/msgpack/wiki/FormatSpec
# http://cpansearch.perl.org/src/YAPPO/Data-Model-0.00006/lib/Data/Model/Driver/Memcached.pm
# http://frox25.no-ip.org/~mtve/wiki/MessagePack.html : reference to using CORE::pack, CORE::unpack

BEGIN {
    my $unpack_int64_slow;
    my $unpack_uint64_slow;

    if(!eval { pack 'Q', 1 }) { # don't have quad types
        # emulates quad types with Math::BigInt.
        # very slow but works well.
        $unpack_int64_slow = sub {
            require Math::BigInt;
            my $high = unpack_uint32( $_[0], $_[1] );
            my $low  = unpack_uint32( $_[0], $_[1] + 4);

            if($high < 0xF0000000) { # positive
                $high = Math::BigInt->new( $high );
                $low  = Math::BigInt->new( $low  );
                return +($high << 32 | $low)->bstr;
            }
            else { # negative
                $high = Math::BigInt->new( ~$high );
                $low  = Math::BigInt->new( ~$low  );
                return +( -($high << 32 | $low + 1) )->bstr;
            }
        };
        $unpack_uint64_slow = sub {
            require Math::BigInt;
            my $high = Math::BigInt->new( unpack_uint32( $_[0], $_[1]) );
            my $low  = Math::BigInt->new( unpack_uint32( $_[0], $_[1] + 4) );
            return +($high << 32 | $low)->bstr;
        };
    }

    *unpack_uint16 = sub { return unpack 'n', substr( $_[0], $_[1], 2 ) };
    *unpack_uint32 = sub { return unpack 'N', substr( $_[0], $_[1], 4 ) };

    # For ARM OABI
    my $bo_is_me = unpack ( 'd', "\x00\x00\xf0\x3f\x00\x00\x00\x00") == 1;
    my $pack_double_oabi;
    my $unpack_double_oabi;

    # for pack and unpack compatibility
    if ( $] < 5.010 ) {
        my $bo_is_le = ( $Config{byteorder} =~ /^1234/ );

        if ($bo_is_me) {
            $pack_double_oabi = sub {
                my @v = unpack( 'V2', pack( 'd', $_[0] ) );
                return pack 'CN2', 0xcb, @v[0,1];
            };
            $unpack_double_oabi = sub {
                my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) );
                return unpack( 'd', pack( 'N2', @v[0,1] ) );
            };
        }

        *unpack_int16  = sub {
            my $v = unpack 'n', substr( $_[0], $_[1], 2 );
            return $v ? $v - 0x10000 : 0;
        };
        *unpack_int32  = sub {
            no warnings; # avoid for warning about Hexadecimal number
            my $v = unpack 'N', substr( $_[0], $_[1], 4 );
            return $v ? $v - 0x100000000 : 0;
        };

        # In reality, since 5.9.2 '>' is introduced. but 'n!' and 'N!'?
        if($bo_is_le) {
            *pack_uint64 = sub {
                my @v = unpack( 'V2', pack( 'Q', $_[0] ) );
                return pack 'CN2', 0xcf, @v[1,0];
            };
            *pack_int64 = sub {
                my @v = unpack( 'V2', pack( 'q', $_[0] ) );
                return pack 'CN2', 0xd3, @v[1,0];
            };
            *pack_double = $pack_double_oabi || sub {
                my @v = unpack( 'V2', pack( 'd', $_[0] ) );
                return pack 'CN2', 0xcb, @v[1,0];
            };

            *unpack_float = sub {
                my @v = unpack( 'v2', substr( $_[0], $_[1], 4 ) );
                return unpack( 'f', pack( 'n2', @v[1,0] ) );
            };
            *unpack_double = $unpack_double_oabi || sub {
                my @v = unpack( 'V2', substr( $_[0], $_[1], 8 ) );
                return unpack( 'd', pack( 'N2', @v[1,0] ) );
            };

            *unpack_int64 = $unpack_int64_slow || sub {
                my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
                return unpack( 'q', pack( 'N2', @v[1,0] ) );
            };
            *unpack_uint64 = $unpack_uint64_slow || sub {
                my @v = unpack( 'V*', substr( $_[0], $_[1], 8 ) );
                return unpack( 'Q', pack( 'N2', @v[1,0] ) );
            };
        }
        else { # big endian
            *pack_uint64   = sub { return pack 'CQ', 0xcf, $_[0]; };
            *pack_int64    = sub { return pack 'Cq', 0xd3, $_[0]; };
            *pack_double   = $pack_double_oabi || sub { return pack 'Cd', 0xcb, $_[0]; };

            *unpack_float  = sub { return unpack( 'f', substr( $_[0], $_[1], 4 ) ); };
            *unpack_double = $unpack_double_oabi || sub { return unpack( 'd', substr( $_[0], $_[1], 8 ) ); };
            *unpack_int64  = $unpack_int64_slow  || sub { unpack 'q', substr( $_[0], $_[1], 8 ); };
            *unpack_uint64 = $unpack_uint64_slow || sub { unpack 'Q', substr( $_[0], $_[1], 8 ); };
        }
    }
    else { # 5.10.0 or later
        if ($bo_is_me) {
            $pack_double_oabi = sub {
                my @v = unpack('V2' , pack('d', $_[0]));
                my $d = unpack('d', pack('V2', @v[1,0]));
                return pack 'Cd>', 0xcb, $d;
            };
            $unpack_double_oabi = sub {
                my $first_word  = substr($_[0], $_[1], 4);
                my $second_word = substr($_[0], $_[1] + 4, 4);
                my $d_bin = $second_word . $first_word;
                return unpack( 'd>', $d_bin );
            };
        }

        # pack_int64/uint64 are used only when the perl support quad types
        *pack_uint64   = sub { return pack 'CQ>', 0xcf, $_[0]; };
        *pack_int64    = sub { return pack 'Cq>', 0xd3, $_[0]; };
        *pack_double   = $pack_double_oabi || sub { return pack 'Cd>', 0xcb, $_[0]; };

        *unpack_float  = sub { return unpack( 'f>', substr( $_[0], $_[1], 4 ) ); };
        *unpack_double = $unpack_double_oabi || sub { return unpack( 'd>', substr( $_[0], $_[1], 8 ) ); };
        *unpack_int16  = sub { return unpack( 'n!', substr( $_[0], $_[1], 2 ) ); };
        *unpack_int32  = sub { return unpack( 'N!', substr( $_[0], $_[1], 4 ) ); };

        *unpack_int64  = $unpack_int64_slow  || sub { return unpack( 'q>', substr( $_[0], $_[1], 8 ) ); };
        *unpack_uint64 = $unpack_uint64_slow || sub { return unpack( 'Q>', substr( $_[0], $_[1], 8 ) ); };
    }

    # fixin package symbols
    no warnings 'once';
    @Data::MessagePack::ISA           = qw(Data::MessagePack::PP);
    @Data::MessagePack::Unpacker::ISA = qw(Data::MessagePack::PP::Unpacker);

    *true  = \&Data::MessagePack::true;
    *false = \&Data::MessagePack::false;
}

sub _unexpected {
    Carp::confess("Unexpected " . sprintf(shift, @_) . " found");
}


#
# PACK
#

our $_max_depth;

sub pack :method {
    my($self, $data, $max_depth) = @_;
    Carp::croak('Usage: Data::MessagePack->pack($dat [,$max_depth])') if @_ < 2;
    $_max_depth = defined $max_depth ? $max_depth : 512; # init

    if(not ref $self) {
        $self = $self->new(
            prefer_integer => $Data::MessagePack::PreferInteger || 0,
            canonical      => $Data::MessagePack::Canonical     || 0,
        );
    }
    return $self->_pack( $data );
}


sub _pack {
    my ( $self, $value ) = @_;

    local $_max_depth = $_max_depth - 1;

    if ( $_max_depth < 0 ) {
        Carp::croak("perl structure exceeds maximum nesting level (max_depth set too low?)");
    }

    return CORE::pack( 'C', 0xc0 ) if ( not defined $value );

    if ( ref($value) eq 'ARRAY' ) {
        my $num = @$value;
        my $header =
              $num < 16          ? CORE::pack( 'C',  0x90 + $num )
            : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xdc,  $num )
            : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdd,  $num )
            : _unexpected("number %d", $num)
        ;
        return join( '', $header, map { $self->_pack( $_ ) } @$value );
    }

    elsif ( ref($value) eq 'HASH' ) {
        my $num = keys %$value;
        my $header =
              $num < 16          ? CORE::pack( 'C',  0x80 + $num )
            : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xde,  $num )
            : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdf,  $num )
            : _unexpected("number %d", $num)
        ;

        if ($self->{canonical}) {
            return join( '', $header, map { $self->_pack( $_ ), $self->_pack($value->{$_}) } sort { $a cmp $b } keys %$value );
        } else {
            return join( '', $header, map { $self->_pack( $_ ) } %$value );
        }
    }

    elsif ( ref( $value ) eq 'Data::MessagePack::Boolean' || ref( $value )->isa('Types::Serialiser::Boolean') ) {
        return  CORE::pack( 'C', ${$value} ? 0xc3 : 0xc2 );
    }


    my $b_obj = B::svref_2object( \$value );
    my $flags = $b_obj->FLAGS;

    if ( $flags & B::SVp_POK ) { # raw / check needs before double

        if ( $self->{prefer_integer} ) {
            if ( $value =~ /^-?[0-9]+$/ ) { # ok?
                # checks whether $value is in (u)int32
                my $ivalue = 0 + $value;
                if (!(
                       $ivalue > 0xFFFFFFFF
                    or $ivalue < ('-' . 0x80000000) # for XS compat
                    or $ivalue != B::svref_2object(\$ivalue)->int_value
                )) {
                    return $self->_pack( $ivalue );
                }
                # fallthrough
            }
            # fallthrough
        }

        utf8::encode( $value ) if utf8::is_utf8( $value );

        my $num = length $value;
        my $header;
        if ($self->{utf8}) { # Str
            $header =
                $num < 32          ? CORE::pack( 'C',  0xa0 + $num )
                : $num < 2 ** 8  - 1 ? CORE::pack( 'CC', 0xd9, $num)
                : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num )
                : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $num )
                : _unexpected('number %d', $num);
        } else { # Bin
            $header =
                $num < 2 ** 8 - 1 ? CORE::pack( 'CC',  0xc4, $num)
                : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xc5, $num )
                : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xc6, $num )
                : _unexpected('number %d', $num);
        }

        return $header . $value;

    }
    elsif( $flags & B::SVp_NOK ) { # double only
        return pack_double( $value );
    }
    elsif ( $flags & B::SVp_IOK ) {
        if ($value >= 0) { # UV
            return    $value <= 127 ?    CORE::pack 'C',        $value
                    : $value < 2 **  8 ? CORE::pack 'CC', 0xcc, $value
                    : $value < 2 ** 16 ? CORE::pack 'Cn', 0xcd, $value
                    : $value < 2 ** 32 ? CORE::pack 'CN', 0xce, $value
                    : pack_uint64( $value );
        }
        else { # IV
            return    -$value <= 32 ?      CORE::pack 'C', ($value & 255)
                    : -$value <= 2 **  7 ? CORE::pack 'Cc', 0xd0, $value
                    : -$value <= 2 ** 15 ? CORE::pack 'Cn', 0xd1, $value
                    : -$value <= 2 ** 31 ? CORE::pack 'CN', 0xd2, $value
                    : pack_int64( $value );
        }
    }
    else {
        _unexpected("data type %s", $b_obj);
    }

}

#
# UNPACK
#

our $_utf8 = 0;
my $p; # position variables for speed.

sub _insufficient {
    Carp::confess("Insufficient bytes (pos=$p, type=@_)");
}

my @byte2value;

sub unpack :method {
    $p = 0; # init
    $_utf8 = (ref($_[0]) && $_[0]->{utf8}) || $_utf8;

    local @byte2value[ 0xc3, 0xc2 ] = ( $Types::Serialiser::true, $Types::Serialiser::false ) if $_[0]->{'prefer_types_serialiser'};

    my $data = _unpack( $_[1] );
    if($p < length($_[1])) {
        Carp::croak("Data::MessagePack->unpack: extra bytes");
    }
    return $data;
}

my $T_STR             = 0x01;
my $T_ARRAY           = 0x02;
my $T_MAP             = 0x04;
my $T_BIN             = 0x08;
my $T_DIRECT          = 0x10; # direct mapping (e.g. 0xc0 <-> nil)

my @typemap = ( (0x00) x 256 );

$typemap[$_] |= $T_ARRAY for
    0x90 .. 0x9f, # fix array
    0xdc,         # array16
    0xdd,         # array32
;
$typemap[$_] |= $T_MAP for
    0x80 .. 0x8f, # fix map
    0xde,         # map16
    0xdf,         # map32
;
$typemap[$_] |= $T_STR for
    0xa0 .. 0xbf, # fix str
    0xd9,         # str8
    0xda,         # str16
    0xdb,         # str32
;
$typemap[$_] |= $T_BIN for
    0xc4,         # bin 8
    0xc5,         # bin 16
    0xc6,         # bin 32
;

foreach my $pair(
    [0xc3, true],
    [0xc2, false],
    [0xc0, undef],

    (map { [ $_, $_ ] }         0x00 .. 0x7f), # positive fixnum
    (map { [ $_, $_ - 0x100 ] } 0xe0 .. 0xff), # negative fixnum
) {
    $typemap[    $pair->[0] ] |= $T_DIRECT;
    $byte2value[ $pair->[0] ]  = $pair->[1];
}

sub _fetch_size {
    my($value_ref, $byte, $x8, $x16, $x32, $x_fixbits) = @_;
    if ( defined($x8) && $byte == $x8 ) {
        $p += 1;
        $p <= length(${$value_ref}) or _insufficient('x/8');
        return unpack 'C', substr( ${$value_ref}, $p - 1, 1);
    }
    elsif ( $byte == $x16 ) {
        $p += 2;
        $p <= length(${$value_ref}) or _insufficient('x/16');
        return unpack 'n', substr( ${$value_ref}, $p - 2, 2 );
    }
    elsif ( $byte == $x32 ) {
        $p += 4;
        $p <= length(${$value_ref}) or _insufficient('x/32');
        return unpack 'N', substr( ${$value_ref}, $p - 4, 4 );
    }
    else { # fix raw
        return $byte & ~$x_fixbits;
    }
}

sub _unpack {
    my ( $value ) = @_;
    $p < length($value) or _insufficient('header byte');
    # get a header byte
    my $byte = ord( substr $value, $p, 1 );
    $p++;

    # +/- fixnum, nil, true, false
    return $byte2value[$byte] if $typemap[$byte] & $T_DIRECT;

    if ( $typemap[$byte] & $T_STR ) {
        my $size = _fetch_size(\$value, $byte, 0xd9, 0xda, 0xdb, 0xa0);
        my $s    = substr( $value, $p, $size );
        length($s) == $size or _insufficient('raw');
        $p      += $size;
        utf8::decode($s);
        return $s;
    }
    elsif ( $typemap[$byte] & $T_ARRAY ) {
        my $size = _fetch_size(\$value, $byte, undef, 0xdc, 0xdd, 0x90);
        my @array;
        push @array, _unpack( $value ) while --$size >= 0;
        return \@array;
    }
    elsif ( $typemap[$byte] & $T_MAP ) {
        my $size = _fetch_size(\$value, $byte, undef, 0xde, 0xdf, 0x80);
        my %map;
        while(--$size >= 0) {
            no warnings; # for undef key case
            my $key = _unpack( $value );
            my $val = _unpack( $value );
            $map{ $key } = $val;
        }
        return \%map;
    }
    elsif ($typemap[$byte] & $T_BIN) {
        my $size = _fetch_size(\$value, $byte, 0xc4, 0xc5, 0xc6, 0x80);
        my $s    = substr( $value, $p, $size );
        length($s) == $size or _insufficient('bin');
        $p      += $size;
        utf8::decode($s) if $_utf8;
        return $s;
    }
    elsif ( $byte == 0xcc ) { # uint8
        $p++;
        $p <= length($value) or _insufficient('uint8');
        return CORE::unpack( 'C', substr( $value, $p - 1, 1 ) );
    }
    elsif ( $byte == 0xcd ) { # uint16
        $p += 2;
        $p <= length($value) or _insufficient('uint16');
        return unpack_uint16( $value, $p - 2 );
    }
    elsif ( $byte == 0xce ) { # unit32
        $p += 4;
        $p <= length($value) or _insufficient('uint32');
        return unpack_uint32( $value, $p - 4 );
    }
    elsif ( $byte == 0xcf ) { # unit64
        $p += 8;
        $p <= length($value) or _insufficient('uint64');
        return unpack_uint64( $value, $p - 8 );
    }
    elsif ( $byte == 0xd3 ) { # int64
        $p += 8;
        $p <= length($value) or _insufficient('int64');
        return unpack_int64( $value, $p - 8 );
    }
    elsif ( $byte == 0xd2 ) { # int32
        $p += 4;
        $p <= length($value) or _insufficient('int32');
        return unpack_int32( $value, $p - 4 );
    }
    elsif ( $byte == 0xd1 ) { # int16
        $p += 2;
        $p <= length($value) or _insufficient('int16');
        return unpack_int16( $value, $p - 2 );
    }
    elsif ( $byte == 0xd0 ) { # int8
        $p++;
        $p <= length($value) or _insufficient('int8');
        return CORE::unpack 'c',  substr( $value, $p - 1, 1 );
    }
    elsif ( $byte == 0xcb ) { # double
        $p += 8;
        $p <= length($value) or _insufficient('double');
        return unpack_double( $value, $p - 8 );
    }
    elsif ( $byte == 0xca ) { # float
        $p += 4;
        $p <= length($value) or _insufficient('float');
        return unpack_float( $value, $p - 4 );
    }
    else {
        _unexpected("byte 0x%02x", $byte);
    }
}


#
# Data::MessagePack::Unpacker
#

package
    Data::MessagePack::PP::Unpacker;

sub new {
    bless {
        pos  => 0,
        utf8 => 0,
        buff => '',
    }, shift;
}

sub utf8 {
    my $self = shift;
    $self->{utf8} = (@_ ? shift : 1);
    return $self;
}

sub get_utf8 {
    my($self) = @_;
    return $self->{utf8};
}

sub execute_limit {
    execute( @_ );
}

sub execute {
    my ( $self, $data, $offset, $limit ) = @_;
    $offset ||= 0;
    my $value = substr( $data, $offset, $limit ? $limit : length $data );
    my $len   = length $value;

    $self->{buff} .= $value;
    local $self->{stack} = [];

    #$p = 0;
    #eval { Data::MessagePack::PP::_unpack($self->{buff}) };
    #warn "[$p][$@]";
    $p = 0;

    while ( length($self->{buff}) > $p ) {
        _count( $self, $self->{buff} ) or last;

        while ( @{ $self->{stack} } > 0 && --$self->{stack}->[-1] == 0) {
            pop @{ $self->{stack} };
        }

        if (@{$self->{stack}} == 0) {
            $self->{is_finished}++;
            last;
        }
    }
    $self->{pos} = $p;

    return $p + $offset;
}


sub _count {
    my ( $self, $value ) = @_;
    no warnings; # FIXME
    my $byte = unpack( 'C', substr( $value, $p++, 1 ) ); # get header

    Carp::croak('invalid data') unless defined $byte;

    # +/- fixnum, nil, true, false
    return 1 if $typemap[$byte] & $T_DIRECT;

    if ( $typemap[$byte] & $T_STR ) {
        my $num;
        if ( $byte == 0xd9 ) {
            $num = unpack 'C', substr( $value, $p, 1 );
            $p += 1;
        }
        elsif ( $byte == 0xda ) {
            $num = unpack 'n', substr( $value, $p, 2 );
            $p += 2;
        }
        elsif ( $byte == 0xdb ) {
            $num = unpack 'N', substr( $value, $p, 4 );
            $p += 4;
        }
        else { # fix raw
            $num = $byte & ~0xa0;
        }
        $p += $num;
        return 1;
    }
    elsif ( $typemap[$byte] & $T_ARRAY ) {
        my $num;
        if ( $byte == 0xdc ) { # array 16
            $num = unpack 'n', substr( $value, $p, 2 );
            $p += 2;
        }
        elsif ( $byte == 0xdd ) { # array 32
            $num = unpack 'N', substr( $value, $p, 4 );
            $p += 4;
        }
        else { # fix array
            $num = $byte & ~0x90;
        }

        if ( $num ) {
            push @{ $self->{stack} }, $num + 1;
        }

        return 1;
    }
    elsif ( $typemap[$byte] & $T_MAP ) {
        my $num;
        if ( $byte == 0xde ) { # map 16
            $num = unpack 'n', substr( $value, $p, 2 );
            $p += 2;
        }
        elsif ( $byte == 0xdf ) { # map 32
            $num = unpack 'N', substr( $value, $p, 4 );
            $p += 4;
        }
        else { # fix map
            $num = $byte & ~0x80;
        }

        if ( $num ) {
            push @{ $self->{stack} }, $num * 2 + 1; # a pair
        }

        return 1;
    }
    elsif ( $typemap[$byte] & $T_BIN ) {
        my $num;
        if ( $byte == 0xc4 ) { # bin 8
            $num = unpack 'C', substr( $value, $p, 1 );
            $p += 1;
        }
        elsif ( $byte == 0xc5 ) { # bin 16
            $num = unpack 'n', substr( $value, $p, 2 );
            $p += 2;
        }
        elsif ( $byte == 0xc6 ) { # bin 32
            $num = unpack 'N', substr( $value, $p, 4 );
            $p += 4;
        }

        $p += $num;
        return 1;
    }
    elsif ( $byte >= 0xcc and $byte <= 0xcf ) { # uint
        $p += $byte == 0xcc ? 1
            : $byte == 0xcd ? 2
            : $byte == 0xce ? 4
            : $byte == 0xcf ? 8
            : Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte);
        return 1;
    }

    elsif ( $byte >= 0xd0 and $byte <= 0xd3 ) { # int
        $p += $byte == 0xd0 ? 1
            : $byte == 0xd1 ? 2
            : $byte == 0xd2 ? 4
            : $byte == 0xd3 ? 8
            : Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte);
        return 1;
    }
    elsif ( $byte == 0xca or $byte == 0xcb ) { # float, double
        $p += $byte == 0xca ? 4 : 8;
        return 1;
    }
    else {
        Data::MessagePack::PP::_unexpected("byte 0x%02x", $byte);
    }

    return 0;
}


sub data {
    my($self) = @_;
    local $Data::MessagePack::PP::_utf8 = $self->{utf8};
    return Data::MessagePack->unpack( substr($self->{buff}, 0, $self->{pos}) );
}


sub is_finished {
    my ( $self ) = @_;
    return $self->{is_finished};
}

sub reset :method {
    $_[0]->{buff}        = '';
    $_[0]->{pos}         = 0;
    $_[0]->{is_finished} = 0;
}

1;
__END__

=pod

=head1 NAME

Data::MessagePack::PP - Pure Perl implementation of Data::MessagePack

=head1 DESCRIPTION

This module is used by L<Data::MessagePack> internally.

=head1 SEE ALSO

L<http://msgpack.sourceforge.jp/>,
L<Data::MessagePack>,
L<http://frox25.no-ip.org/~mtve/wiki/MessagePack.html>,

=head1 AUTHOR

makamaka

=head1 COPYRIGHT AND LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut