Data-MessagePack-0.49/0000755000175000017500000000000012624050607014064 5ustar syoheisyoheiData-MessagePack-0.49/benchmark/0000755000175000017500000000000012624050607016016 5ustar syoheisyoheiData-MessagePack-0.49/benchmark/serialize.pl0000644000175000017500000000077412624045420020347 0ustar syoheisyoheiuse strict; use warnings; use Data::MessagePack; use JSON; use Storable; use Benchmark ':all'; my $a = do 'benchmark/data.pl'; print "-- serialize\n"; print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; cmpthese timethese( -1 => { json => sub { JSON::encode_json($a) }, storable => sub { Storable::freeze($a) }, mp => sub { Data::MessagePack->pack($a) }, } ); Data-MessagePack-0.49/benchmark/data.pl0000755000175000017500000000033312624045420017263 0ustar syoheisyohei+{ "method" => "handleMessage", "params" => [ "user1", "we were just talking", "foo\nbar\nbaz\nqux" ], "id" => undef, "array" => [ 1, 1024, 70000, -5, 1e5, 1e7, 1, 0, 3.14, sqrt(2), 1 .. 100 ], }; Data-MessagePack-0.49/benchmark/size.pl0000644000175000017500000000124712624045420017326 0ustar syoheisyohei#!/usr/bin/perl use strict; use warnings; use Data::MessagePack; use Storable; use Text::SimpleTable; my @entries = ( '1', '3.14', '{}', '[]', "[('a')x10]", "{('a')x10}", "+{1,+{1,+{}}}", "+[+[+[]]]", ); my $table = Text::SimpleTable->new([15, 'src'], [9, 'storable'], [7, 'msgpack']); for my $src (@entries) { my $e = eval $src; die $@ if $@; $table->row( $src, length(Storable::nfreeze(ref $e ? $e : \$e)), length(Data::MessagePack->pack($e)), ); } print "perl: $]\n"; print "Storable: $Storable::VERSION\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "\n"; print $table->draw; Data-MessagePack-0.49/benchmark/deserialize.pl0000644000175000017500000000121612624045420020650 0ustar syoheisyoheiuse strict; use warnings; use Data::MessagePack; use JSON; use Storable; use Benchmark ':all'; #$Data::MessagePack::PreferInteger = 1; my $a = do 'benchmark/data.pl'; my $j = JSON::encode_json($a); my $m = Data::MessagePack->pack($a); my $s = Storable::freeze($a); print "-- deserialize\n"; print "$JSON::Backend: ", $JSON::Backend->VERSION, "\n"; print "Data::MessagePack: $Data::MessagePack::VERSION\n"; print "Storable: $Storable::VERSION\n"; cmpthese timethese( -1 => { json => sub { JSON::decode_json($j) }, mp => sub { Data::MessagePack->unpack($m) }, storable => sub { Storable::thaw($s) }, } ); Data-MessagePack-0.49/include/0000755000175000017500000000000012624050607015507 5ustar syoheisyoheiData-MessagePack-0.49/include/msgpack/0000755000175000017500000000000012624050607017134 5ustar syoheisyoheiData-MessagePack-0.49/include/msgpack/pack_define.h0000644000175000017500000000152512624050607021540 0ustar syoheisyohei/* * MessagePack unpacking routine template * * Copyright (C) 2008-2010 FURUHASHI Sadayuki * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ #ifndef MSGPACK_PACK_DEFINE_H__ #define MSGPACK_PACK_DEFINE_H__ #include "msgpack/sysdep.h" #include #include #endif /* msgpack/pack_define.h */ Data-MessagePack-0.49/include/msgpack/unpack_define.h0000644000175000017500000000427412624050607022107 0ustar syoheisyohei/* * MessagePack unpacking routine template * * Copyright (C) 2008-2010 FURUHASHI Sadayuki * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ #ifndef MSGPACK_UNPACK_DEFINE_H__ #define MSGPACK_UNPACK_DEFINE_H__ #include "msgpack/sysdep.h" #include #include #include #include #ifdef __cplusplus extern "C" { #endif #ifndef MSGPACK_EMBED_STACK_SIZE #define MSGPACK_EMBED_STACK_SIZE 32 #endif typedef enum { CS_HEADER = 0x00, // nil //CS_ = 0x01, //CS_ = 0x02, // false //CS_ = 0x03, // true //CS_ = 0x04, //CS_ = 0x05, //CS_ = 0x06, //CS_ = 0x07, //CS_ = 0x08, //CS_ = 0x09, CS_FLOAT = 0x0a, CS_DOUBLE = 0x0b, CS_UINT_8 = 0x0c, CS_UINT_16 = 0x0d, CS_UINT_32 = 0x0e, CS_UINT_64 = 0x0f, CS_INT_8 = 0x10, CS_INT_16 = 0x11, CS_INT_32 = 0x12, CS_INT_64 = 0x13, //CS_ = 0x14, //CS_ = 0x15, //CS_BIG_INT_16 = 0x16, //CS_BIG_INT_32 = 0x17, //CS_BIG_FLOAT_16 = 0x18, //CS_BIG_FLOAT_32 = 0x19, CS_RAW_16 = 0x1a, CS_RAW_32 = 0x1b, CS_ARRAY_16 = 0x1c, CS_ARRAY_32 = 0x1d, CS_MAP_16 = 0x1e, CS_MAP_32 = 0x1f, //ACS_BIG_INT_VALUE, //ACS_BIG_FLOAT_VALUE, ACS_RAW_VALUE, } msgpack_unpack_state; typedef enum { CT_ARRAY_ITEM, CT_MAP_KEY, CT_MAP_VALUE, } msgpack_container_type; #ifdef __cplusplus } #endif #endif /* msgpack/unpack_define.h */ Data-MessagePack-0.49/include/msgpack/sysdep.h0000644000175000017500000001450112624050607020615 0ustar syoheisyohei/* * MessagePack system dependencies * * Copyright (C) 2008-2010 FURUHASHI Sadayuki * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ #ifndef MSGPACK_SYSDEP_H__ #define MSGPACK_SYSDEP_H__ #include #include #if defined(_MSC_VER) && _MSC_VER < 1600 typedef __int8 int8_t; typedef unsigned __int8 uint8_t; typedef __int16 int16_t; typedef unsigned __int16 uint16_t; typedef __int32 int32_t; typedef unsigned __int32 uint32_t; typedef __int64 int64_t; typedef unsigned __int64 uint64_t; #elif defined(_MSC_VER) // && _MSC_VER >= 1600 #include #else #include #include #endif #ifdef _WIN32 #define _msgpack_atomic_counter_header typedef long _msgpack_atomic_counter_t; #define _msgpack_sync_decr_and_fetch(ptr) InterlockedDecrement(ptr) #define _msgpack_sync_incr_and_fetch(ptr) InterlockedIncrement(ptr) #elif defined(__GNUC__) && ((__GNUC__*10 + __GNUC_MINOR__) < 41) #define _msgpack_atomic_counter_header "gcc_atomic.h" #else typedef unsigned int _msgpack_atomic_counter_t; #define _msgpack_sync_decr_and_fetch(ptr) __sync_sub_and_fetch(ptr, 1) #define _msgpack_sync_incr_and_fetch(ptr) __sync_add_and_fetch(ptr, 1) #endif #ifdef _WIN32 #ifdef __cplusplus /* numeric_limits::min,max */ #ifdef max #undef max #endif #ifdef min #undef min #endif #endif #else #include /* __BYTE_ORDER */ #endif #if !defined(__LITTLE_ENDIAN__) && !defined(__BIG_ENDIAN__) #if __BYTE_ORDER == __LITTLE_ENDIAN #define __LITTLE_ENDIAN__ #elif __BYTE_ORDER == __BIG_ENDIAN #define __BIG_ENDIAN__ #elif _WIN32 #define __LITTLE_ENDIAN__ #endif #endif #ifdef __LITTLE_ENDIAN__ #ifdef _WIN32 # if defined(ntohs) # define _msgpack_be16(x) ntohs(x) # elif defined(_byteswap_ushort) || (defined(_MSC_VER) && _MSC_VER >= 1400) # define _msgpack_be16(x) ((uint16_t)_byteswap_ushort((unsigned short)x)) # else # define _msgpack_be16(x) ( \ ((((uint16_t)x) << 8) ) | \ ((((uint16_t)x) >> 8) ) ) # endif #else # define _msgpack_be16(x) ntohs(x) #endif #ifdef _WIN32 # if defined(ntohl) # define _msgpack_be32(x) ntohl(x) # elif defined(_byteswap_ulong) || (defined(_MSC_VER) && _MSC_VER >= 1400) # define _msgpack_be32(x) ((uint32_t)_byteswap_ulong((unsigned long)x)) # else # define _msgpack_be32(x) \ ( ((((uint32_t)x) << 24) ) | \ ((((uint32_t)x) << 8) & 0x00ff0000U ) | \ ((((uint32_t)x) >> 8) & 0x0000ff00U ) | \ ((((uint32_t)x) >> 24) ) ) # endif #else # define _msgpack_be32(x) ntohl(x) #endif #if defined(_byteswap_uint64) || (defined(_MSC_VER) && _MSC_VER >= 1400) # define _msgpack_be64(x) (_byteswap_uint64(x)) #elif defined(bswap_64) # define _msgpack_be64(x) bswap_64(x) #elif defined(__DARWIN_OSSwapInt64) # define _msgpack_be64(x) __DARWIN_OSSwapInt64(x) #else #define _msgpack_be64(x) \ ( ((((uint64_t)x) << 56) ) | \ ((((uint64_t)x) << 40) & 0x00ff000000000000ULL ) | \ ((((uint64_t)x) << 24) & 0x0000ff0000000000ULL ) | \ ((((uint64_t)x) << 8) & 0x000000ff00000000ULL ) | \ ((((uint64_t)x) >> 8) & 0x00000000ff000000ULL ) | \ ((((uint64_t)x) >> 24) & 0x0000000000ff0000ULL ) | \ ((((uint64_t)x) >> 40) & 0x000000000000ff00ULL ) | \ ((((uint64_t)x) >> 56) ) ) #endif #define _msgpack_load16(cast, from) ((cast)( \ (((uint16_t)((uint8_t*)(from))[0]) << 8) | \ (((uint16_t)((uint8_t*)(from))[1]) ) )) #define _msgpack_load32(cast, from) ((cast)( \ (((uint32_t)((uint8_t*)(from))[0]) << 24) | \ (((uint32_t)((uint8_t*)(from))[1]) << 16) | \ (((uint32_t)((uint8_t*)(from))[2]) << 8) | \ (((uint32_t)((uint8_t*)(from))[3]) ) )) #define _msgpack_load64(cast, from) ((cast)( \ (((uint64_t)((uint8_t*)(from))[0]) << 56) | \ (((uint64_t)((uint8_t*)(from))[1]) << 48) | \ (((uint64_t)((uint8_t*)(from))[2]) << 40) | \ (((uint64_t)((uint8_t*)(from))[3]) << 32) | \ (((uint64_t)((uint8_t*)(from))[4]) << 24) | \ (((uint64_t)((uint8_t*)(from))[5]) << 16) | \ (((uint64_t)((uint8_t*)(from))[6]) << 8) | \ (((uint64_t)((uint8_t*)(from))[7]) ) )) #else #define _msgpack_be16(x) (x) #define _msgpack_be32(x) (x) #define _msgpack_be64(x) (x) #define _msgpack_load16(cast, from) ((cast)( \ (((uint16_t)((uint8_t*)from)[0]) << 8) | \ (((uint16_t)((uint8_t*)from)[1]) ) )) #define _msgpack_load32(cast, from) ((cast)( \ (((uint32_t)((uint8_t*)from)[0]) << 24) | \ (((uint32_t)((uint8_t*)from)[1]) << 16) | \ (((uint32_t)((uint8_t*)from)[2]) << 8) | \ (((uint32_t)((uint8_t*)from)[3]) ) )) #define _msgpack_load64(cast, from) ((cast)( \ (((uint64_t)((uint8_t*)from)[0]) << 56) | \ (((uint64_t)((uint8_t*)from)[1]) << 48) | \ (((uint64_t)((uint8_t*)from)[2]) << 40) | \ (((uint64_t)((uint8_t*)from)[3]) << 32) | \ (((uint64_t)((uint8_t*)from)[4]) << 24) | \ (((uint64_t)((uint8_t*)from)[5]) << 16) | \ (((uint64_t)((uint8_t*)from)[6]) << 8) | \ (((uint64_t)((uint8_t*)from)[7]) ) )) #endif #define _msgpack_store16(to, num) \ do { uint16_t val = _msgpack_be16(num); memcpy(to, &val, 2); } while(0) #define _msgpack_store32(to, num) \ do { uint32_t val = _msgpack_be32(num); memcpy(to, &val, 4); } while(0) #define _msgpack_store64(to, num) \ do { uint64_t val = _msgpack_be64(num); memcpy(to, &val, 8); } while(0) /* #define _msgpack_load16(cast, from) \ ({ cast val; memcpy(&val, (char*)from, 2); _msgpack_be16(val); }) #define _msgpack_load32(cast, from) \ ({ cast val; memcpy(&val, (char*)from, 4); _msgpack_be32(val); }) #define _msgpack_load64(cast, from) \ ({ cast val; memcpy(&val, (char*)from, 8); _msgpack_be64(val); }) */ #endif /* msgpack/sysdep.h */ Data-MessagePack-0.49/include/msgpack/pack_template.h0000644000175000017500000004331412624050607022123 0ustar syoheisyohei/* * MessagePack packing routine template * * Copyright (C) 2008-2010 FURUHASHI Sadayuki * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ #if defined(__LITTLE_ENDIAN__) #define TAKE8_8(d) ((uint8_t*)&d)[0] #define TAKE8_16(d) ((uint8_t*)&d)[0] #define TAKE8_32(d) ((uint8_t*)&d)[0] #define TAKE8_64(d) ((uint8_t*)&d)[0] #elif defined(__BIG_ENDIAN__) #define TAKE8_8(d) ((uint8_t*)&d)[0] #define TAKE8_16(d) ((uint8_t*)&d)[1] #define TAKE8_32(d) ((uint8_t*)&d)[3] #define TAKE8_64(d) ((uint8_t*)&d)[7] #endif #ifndef msgpack_pack_inline_func #error msgpack_pack_inline_func template is not defined #endif #ifndef msgpack_pack_user #error msgpack_pack_user type is not defined #endif #ifndef msgpack_pack_append_buffer #error msgpack_pack_append_buffer callback is not defined #endif /* * Integer */ #define msgpack_pack_real_uint8(x, d) \ do { \ if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_8(d), 1); \ } else { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_8(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } while(0) #define msgpack_pack_real_uint16(x, d) \ do { \ if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_16(d), 1); \ } else if(d < (1<<8)) { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_16(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } else { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } \ } while(0) #define msgpack_pack_real_uint32(x, d) \ do { \ if(d < (1<<8)) { \ if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_32(d), 1); \ } else { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_32(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } else { \ if(d < (1<<16)) { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else { \ /* unsigned 32 */ \ unsigned char buf[5]; \ buf[0] = 0xce; _msgpack_store32(&buf[1], (uint32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } \ } \ } while(0) #define msgpack_pack_real_uint64(x, d) \ do { \ if(d < (1ULL<<8)) { \ if(d < (1ULL<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_64(d), 1); \ } else { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_64(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } else { \ if(d < (1ULL<<16)) { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else if(d < (1ULL<<32)) { \ /* unsigned 32 */ \ unsigned char buf[5]; \ buf[0] = 0xce; _msgpack_store32(&buf[1], (uint32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } else { \ /* unsigned 64 */ \ unsigned char buf[9]; \ buf[0] = 0xcf; _msgpack_store64(&buf[1], d); \ msgpack_pack_append_buffer(x, buf, 9); \ } \ } \ } while(0) #define msgpack_pack_real_int8(x, d) \ do { \ if(d < -(1<<5)) { \ /* signed 8 */ \ unsigned char buf[2] = {0xd0, TAKE8_8(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } else { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_8(d), 1); \ } \ } while(0) #define msgpack_pack_real_int16(x, d) \ do { \ if(d < -(1<<5)) { \ if(d < -(1<<7)) { \ /* signed 16 */ \ unsigned char buf[3]; \ buf[0] = 0xd1; _msgpack_store16(&buf[1], (int16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else { \ /* signed 8 */ \ unsigned char buf[2] = {0xd0, TAKE8_16(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } else if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_16(d), 1); \ } else { \ if(d < (1<<8)) { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_16(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } else { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } \ } \ } while(0) #define msgpack_pack_real_int32(x, d) \ do { \ if(d < -(1<<5)) { \ if(d < -(1<<15)) { \ /* signed 32 */ \ unsigned char buf[5]; \ buf[0] = 0xd2; _msgpack_store32(&buf[1], (int32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } else if(d < -(1<<7)) { \ /* signed 16 */ \ unsigned char buf[3]; \ buf[0] = 0xd1; _msgpack_store16(&buf[1], (int16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else { \ /* signed 8 */ \ unsigned char buf[2] = {0xd0, TAKE8_32(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } else if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_32(d), 1); \ } else { \ if(d < (1<<8)) { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_32(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } else if(d < (1<<16)) { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else { \ /* unsigned 32 */ \ unsigned char buf[5]; \ buf[0] = 0xce; _msgpack_store32(&buf[1], (uint32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } \ } \ } while(0) #define msgpack_pack_real_int64(x, d) \ do { \ if(d < -(1LL<<5)) { \ if(d < -(1LL<<15)) { \ if(d < -(1LL<<31)) { \ /* signed 64 */ \ unsigned char buf[9]; \ buf[0] = 0xd3; _msgpack_store64(&buf[1], d); \ msgpack_pack_append_buffer(x, buf, 9); \ } else { \ /* signed 32 */ \ unsigned char buf[5]; \ buf[0] = 0xd2; _msgpack_store32(&buf[1], (int32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } \ } else { \ if(d < -(1<<7)) { \ /* signed 16 */ \ unsigned char buf[3]; \ buf[0] = 0xd1; _msgpack_store16(&buf[1], (int16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } else { \ /* signed 8 */ \ unsigned char buf[2] = {0xd0, TAKE8_64(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } \ } \ } else if(d < (1<<7)) { \ /* fixnum */ \ msgpack_pack_append_buffer(x, &TAKE8_64(d), 1); \ } else { \ if(d < (1LL<<16)) { \ if(d < (1<<8)) { \ /* unsigned 8 */ \ unsigned char buf[2] = {0xcc, TAKE8_64(d)}; \ msgpack_pack_append_buffer(x, buf, 2); \ } else { \ /* unsigned 16 */ \ unsigned char buf[3]; \ buf[0] = 0xcd; _msgpack_store16(&buf[1], (uint16_t)d); \ msgpack_pack_append_buffer(x, buf, 3); \ } \ } else { \ if(d < (1LL<<32)) { \ /* unsigned 32 */ \ unsigned char buf[5]; \ buf[0] = 0xce; _msgpack_store32(&buf[1], (uint32_t)d); \ msgpack_pack_append_buffer(x, buf, 5); \ } else { \ /* unsigned 64 */ \ unsigned char buf[9]; \ buf[0] = 0xcf; _msgpack_store64(&buf[1], d); \ msgpack_pack_append_buffer(x, buf, 9); \ } \ } \ } \ } while(0) #ifdef msgpack_pack_inline_func_fixint msgpack_pack_inline_func_fixint(_uint8)(msgpack_pack_user x, uint8_t d) { unsigned char buf[2] = {0xcc, TAKE8_8(d)}; msgpack_pack_append_buffer(x, buf, 2); } msgpack_pack_inline_func_fixint(_uint16)(msgpack_pack_user x, uint16_t d) { unsigned char buf[3]; buf[0] = 0xcd; _msgpack_store16(&buf[1], d); msgpack_pack_append_buffer(x, buf, 3); } msgpack_pack_inline_func_fixint(_uint32)(msgpack_pack_user x, uint32_t d) { unsigned char buf[5]; buf[0] = 0xce; _msgpack_store32(&buf[1], d); msgpack_pack_append_buffer(x, buf, 5); } msgpack_pack_inline_func_fixint(_uint64)(msgpack_pack_user x, uint64_t d) { unsigned char buf[9]; buf[0] = 0xcf; _msgpack_store64(&buf[1], d); msgpack_pack_append_buffer(x, buf, 9); } msgpack_pack_inline_func_fixint(_int8)(msgpack_pack_user x, int8_t d) { unsigned char buf[2] = {0xd0, TAKE8_8(d)}; msgpack_pack_append_buffer(x, buf, 2); } msgpack_pack_inline_func_fixint(_int16)(msgpack_pack_user x, int16_t d) { unsigned char buf[3]; buf[0] = 0xd1; _msgpack_store16(&buf[1], d); msgpack_pack_append_buffer(x, buf, 3); } msgpack_pack_inline_func_fixint(_int32)(msgpack_pack_user x, int32_t d) { unsigned char buf[5]; buf[0] = 0xd2; _msgpack_store32(&buf[1], d); msgpack_pack_append_buffer(x, buf, 5); } msgpack_pack_inline_func_fixint(_int64)(msgpack_pack_user x, int64_t d) { unsigned char buf[9]; buf[0] = 0xd3; _msgpack_store64(&buf[1], d); msgpack_pack_append_buffer(x, buf, 9); } #undef msgpack_pack_inline_func_fixint #endif msgpack_pack_inline_func(_uint8)(msgpack_pack_user x, uint8_t d) { msgpack_pack_real_uint8(x, d); } msgpack_pack_inline_func(_uint16)(msgpack_pack_user x, uint16_t d) { msgpack_pack_real_uint16(x, d); } msgpack_pack_inline_func(_uint32)(msgpack_pack_user x, uint32_t d) { msgpack_pack_real_uint32(x, d); } msgpack_pack_inline_func(_uint64)(msgpack_pack_user x, uint64_t d) { msgpack_pack_real_uint64(x, d); } msgpack_pack_inline_func(_int8)(msgpack_pack_user x, int8_t d) { msgpack_pack_real_int8(x, d); } msgpack_pack_inline_func(_int16)(msgpack_pack_user x, int16_t d) { msgpack_pack_real_int16(x, d); } msgpack_pack_inline_func(_int32)(msgpack_pack_user x, int32_t d) { msgpack_pack_real_int32(x, d); } msgpack_pack_inline_func(_int64)(msgpack_pack_user x, int64_t d) { msgpack_pack_real_int64(x, d); } #ifdef msgpack_pack_inline_func_cint msgpack_pack_inline_func_cint(_short)(msgpack_pack_user x, short d) { #if defined(SIZEOF_SHORT) #if SIZEOF_SHORT == 2 msgpack_pack_real_int16(x, d); #elif SIZEOF_SHORT == 4 msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #elif defined(SHRT_MAX) #if SHRT_MAX == 0x7fff msgpack_pack_real_int16(x, d); #elif SHRT_MAX == 0x7fffffff msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #else if(sizeof(short) == 2) { msgpack_pack_real_int16(x, d); } else if(sizeof(short) == 4) { msgpack_pack_real_int32(x, d); } else { msgpack_pack_real_int64(x, d); } #endif } msgpack_pack_inline_func_cint(_int)(msgpack_pack_user x, int d) { #if defined(SIZEOF_INT) #if SIZEOF_INT == 2 msgpack_pack_real_int16(x, d); #elif SIZEOF_INT == 4 msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #elif defined(INT_MAX) #if INT_MAX == 0x7fff msgpack_pack_real_int16(x, d); #elif INT_MAX == 0x7fffffff msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #else if(sizeof(int) == 2) { msgpack_pack_real_int16(x, d); } else if(sizeof(int) == 4) { msgpack_pack_real_int32(x, d); } else { msgpack_pack_real_int64(x, d); } #endif } msgpack_pack_inline_func_cint(_long)(msgpack_pack_user x, long d) { #if defined(SIZEOF_LONG) #if SIZEOF_LONG == 2 msgpack_pack_real_int16(x, d); #elif SIZEOF_LONG == 4 msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #elif defined(LONG_MAX) #if LONG_MAX == 0x7fffL msgpack_pack_real_int16(x, d); #elif LONG_MAX == 0x7fffffffL msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #else if(sizeof(long) == 2) { msgpack_pack_real_int16(x, d); } else if(sizeof(long) == 4) { msgpack_pack_real_int32(x, d); } else { msgpack_pack_real_int64(x, d); } #endif } msgpack_pack_inline_func_cint(_long_long)(msgpack_pack_user x, long long d) { #if defined(SIZEOF_LONG_LONG) #if SIZEOF_LONG_LONG == 2 msgpack_pack_real_int16(x, d); #elif SIZEOF_LONG_LONG == 4 msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #elif defined(LLONG_MAX) #if LLONG_MAX == 0x7fffL msgpack_pack_real_int16(x, d); #elif LLONG_MAX == 0x7fffffffL msgpack_pack_real_int32(x, d); #else msgpack_pack_real_int64(x, d); #endif #else if(sizeof(long long) == 2) { msgpack_pack_real_int16(x, d); } else if(sizeof(long long) == 4) { msgpack_pack_real_int32(x, d); } else { msgpack_pack_real_int64(x, d); } #endif } msgpack_pack_inline_func_cint(_unsigned_short)(msgpack_pack_user x, unsigned short d) { #if defined(SIZEOF_SHORT) #if SIZEOF_SHORT == 2 msgpack_pack_real_uint16(x, d); #elif SIZEOF_SHORT == 4 msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #elif defined(USHRT_MAX) #if USHRT_MAX == 0xffffU msgpack_pack_real_uint16(x, d); #elif USHRT_MAX == 0xffffffffU msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #else if(sizeof(unsigned short) == 2) { msgpack_pack_real_uint16(x, d); } else if(sizeof(unsigned short) == 4) { msgpack_pack_real_uint32(x, d); } else { msgpack_pack_real_uint64(x, d); } #endif } msgpack_pack_inline_func_cint(_unsigned_int)(msgpack_pack_user x, unsigned int d) { #if defined(SIZEOF_INT) #if SIZEOF_INT == 2 msgpack_pack_real_uint16(x, d); #elif SIZEOF_INT == 4 msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #elif defined(UINT_MAX) #if UINT_MAX == 0xffffU msgpack_pack_real_uint16(x, d); #elif UINT_MAX == 0xffffffffU msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #else if(sizeof(unsigned int) == 2) { msgpack_pack_real_uint16(x, d); } else if(sizeof(unsigned int) == 4) { msgpack_pack_real_uint32(x, d); } else { msgpack_pack_real_uint64(x, d); } #endif } msgpack_pack_inline_func_cint(_unsigned_long)(msgpack_pack_user x, unsigned long d) { #if defined(SIZEOF_LONG) #if SIZEOF_LONG == 2 msgpack_pack_real_uint16(x, d); #elif SIZEOF_LONG == 4 msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #elif defined(ULONG_MAX) #if ULONG_MAX == 0xffffUL msgpack_pack_real_uint16(x, d); #elif ULONG_MAX == 0xffffffffUL msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #else if(sizeof(unsigned long) == 2) { msgpack_pack_real_uint16(x, d); } else if(sizeof(unsigned long) == 4) { msgpack_pack_real_uint32(x, d); } else { msgpack_pack_real_uint64(x, d); } #endif } msgpack_pack_inline_func_cint(_unsigned_long_long)(msgpack_pack_user x, unsigned long long d) { #if defined(SIZEOF_LONG_LONG) #if SIZEOF_LONG_LONG == 2 msgpack_pack_real_uint16(x, d); #elif SIZEOF_LONG_LONG == 4 msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #elif defined(ULLONG_MAX) #if ULLONG_MAX == 0xffffUL msgpack_pack_real_uint16(x, d); #elif ULLONG_MAX == 0xffffffffUL msgpack_pack_real_uint32(x, d); #else msgpack_pack_real_uint64(x, d); #endif #else if(sizeof(unsigned long long) == 2) { msgpack_pack_real_uint16(x, d); } else if(sizeof(unsigned long long) == 4) { msgpack_pack_real_uint32(x, d); } else { msgpack_pack_real_uint64(x, d); } #endif } #undef msgpack_pack_inline_func_cint #endif /* * Float */ msgpack_pack_inline_func(_float)(msgpack_pack_user x, float d) { union { float f; uint32_t i; } mem; mem.f = d; unsigned char buf[5]; buf[0] = 0xca; _msgpack_store32(&buf[1], mem.i); msgpack_pack_append_buffer(x, buf, 5); } msgpack_pack_inline_func(_double)(msgpack_pack_user x, double d) { union { double f; uint64_t i; } mem; mem.f = d; unsigned char buf[9]; buf[0] = 0xcb; #if defined(__arm__) && !(__ARM_EABI__) // arm-oabi // https://github.com/msgpack/msgpack-perl/pull/1 mem.i = (mem.i & 0xFFFFFFFFUL) << 32UL | (mem.i >> 32UL); #endif _msgpack_store64(&buf[1], mem.i); msgpack_pack_append_buffer(x, buf, 9); } /* * Nil */ msgpack_pack_inline_func(_nil)(msgpack_pack_user x) { static const unsigned char d = 0xc0; msgpack_pack_append_buffer(x, &d, 1); } /* * Boolean */ msgpack_pack_inline_func(_true)(msgpack_pack_user x) { static const unsigned char d = 0xc3; msgpack_pack_append_buffer(x, &d, 1); } msgpack_pack_inline_func(_false)(msgpack_pack_user x) { static const unsigned char d = 0xc2; msgpack_pack_append_buffer(x, &d, 1); } /* * Array */ msgpack_pack_inline_func(_array)(msgpack_pack_user x, unsigned int n) { if(n < 16) { unsigned char d = 0x90 | n; msgpack_pack_append_buffer(x, &d, 1); } else if(n < 65536) { unsigned char buf[3]; buf[0] = 0xdc; _msgpack_store16(&buf[1], (uint16_t)n); msgpack_pack_append_buffer(x, buf, 3); } else { unsigned char buf[5]; buf[0] = 0xdd; _msgpack_store32(&buf[1], (uint32_t)n); msgpack_pack_append_buffer(x, buf, 5); } } /* * Map */ msgpack_pack_inline_func(_map)(msgpack_pack_user x, unsigned int n) { if(n < 16) { unsigned char d = 0x80 | n; msgpack_pack_append_buffer(x, &TAKE8_8(d), 1); } else if(n < 65536) { unsigned char buf[3]; buf[0] = 0xde; _msgpack_store16(&buf[1], (uint16_t)n); msgpack_pack_append_buffer(x, buf, 3); } else { unsigned char buf[5]; buf[0] = 0xdf; _msgpack_store32(&buf[1], (uint32_t)n); msgpack_pack_append_buffer(x, buf, 5); } } /* * Raw */ msgpack_pack_inline_func(_raw)(msgpack_pack_user x, size_t l) { if(l < 32) { unsigned char d = 0xa0 | (uint8_t)l; msgpack_pack_append_buffer(x, &TAKE8_8(d), 1); } else if(l < 65536) { unsigned char buf[3]; buf[0] = 0xda; _msgpack_store16(&buf[1], (uint16_t)l); msgpack_pack_append_buffer(x, buf, 3); } else { unsigned char buf[5]; buf[0] = 0xdb; _msgpack_store32(&buf[1], (uint32_t)l); msgpack_pack_append_buffer(x, buf, 5); } } msgpack_pack_inline_func(_raw_body)(msgpack_pack_user x, const void* b, size_t l) { msgpack_pack_append_buffer(x, (const unsigned char*)b, l); } #undef msgpack_pack_inline_func #undef msgpack_pack_user #undef msgpack_pack_append_buffer #undef TAKE8_8 #undef TAKE8_16 #undef TAKE8_32 #undef TAKE8_64 #undef msgpack_pack_real_uint8 #undef msgpack_pack_real_uint16 #undef msgpack_pack_real_uint32 #undef msgpack_pack_real_uint64 #undef msgpack_pack_real_int8 #undef msgpack_pack_real_int16 #undef msgpack_pack_real_int32 #undef msgpack_pack_real_int64 Data-MessagePack-0.49/include/msgpack/unpack_template.h0000644000175000017500000002625512624050607022473 0ustar syoheisyohei/* * MessagePack unpacking routine template * * Copyright (C) 2008-2010 FURUHASHI Sadayuki * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. */ #ifndef msgpack_unpack_func #error msgpack_unpack_func template is not defined #endif #ifndef msgpack_unpack_callback #error msgpack_unpack_callback template is not defined #endif #ifndef msgpack_unpack_struct #error msgpack_unpack_struct template is not defined #endif #ifndef msgpack_unpack_struct_decl #define msgpack_unpack_struct_decl(name) msgpack_unpack_struct(name) #endif #ifndef msgpack_unpack_object #error msgpack_unpack_object type is not defined #endif #ifndef msgpack_unpack_user #error msgpack_unpack_user type is not defined #endif #ifndef USE_CASE_RANGE #if !defined(_MSC_VER) #define USE_CASE_RANGE #endif #endif msgpack_unpack_struct_decl(_stack) { msgpack_unpack_object obj; size_t count; unsigned int ct; msgpack_unpack_object map_key; }; msgpack_unpack_struct_decl(_context) { msgpack_unpack_user user; unsigned int cs; unsigned int trail; unsigned int top; /* msgpack_unpack_struct(_stack)* stack; unsigned int stack_size; msgpack_unpack_struct(_stack) embed_stack[MSGPACK_EMBED_STACK_SIZE]; */ msgpack_unpack_struct(_stack) stack[MSGPACK_EMBED_STACK_SIZE]; }; msgpack_unpack_func(void, _init)(msgpack_unpack_struct(_context)* ctx) { ctx->cs = CS_HEADER; ctx->trail = 0; ctx->top = 0; /* ctx->stack = ctx->embed_stack; ctx->stack_size = MSGPACK_EMBED_STACK_SIZE; */ ctx->stack[0].obj = msgpack_unpack_callback(_root)(&ctx->user); } /* msgpack_unpack_func(void, _destroy)(msgpack_unpack_struct(_context)* ctx) { if(ctx->stack_size != MSGPACK_EMBED_STACK_SIZE) { free(ctx->stack); } } */ msgpack_unpack_func(msgpack_unpack_object, _data)(msgpack_unpack_struct(_context)* ctx) { return (ctx)->stack[0].obj; } msgpack_unpack_func(int, _execute)(msgpack_unpack_struct(_context)* ctx, const char* data, size_t len, size_t* off) { assert(len >= *off); const unsigned char* p = (unsigned char*)data + *off; const unsigned char* const pe = (unsigned char*)data + len; const void* n = NULL; unsigned int trail = ctx->trail; unsigned int cs = ctx->cs; unsigned int top = ctx->top; msgpack_unpack_struct(_stack)* stack = ctx->stack; /* unsigned int stack_size = ctx->stack_size; */ msgpack_unpack_user* user = &ctx->user; msgpack_unpack_object obj; msgpack_unpack_struct(_stack)* c = NULL; int ret; #define push_simple_value(func) \ if(msgpack_unpack_callback(func)(user, &obj) < 0) { goto _failed; } \ goto _push #define push_fixed_value(func, arg) \ if(msgpack_unpack_callback(func)(user, arg, &obj) < 0) { goto _failed; } \ goto _push #define push_variable_value(func, base, pos, len) \ if(msgpack_unpack_callback(func)(user, \ (const char*)base, (const char*)pos, len, &obj) < 0) { goto _failed; } \ goto _push #define again_fixed_trail(_cs, trail_len) \ trail = trail_len; \ cs = _cs; \ goto _fixed_trail_again #define again_fixed_trail_if_zero(_cs, trail_len, ifzero) \ trail = trail_len; \ if(trail == 0) { goto ifzero; } \ cs = _cs; \ goto _fixed_trail_again #define start_container(func, count_, ct_) \ if(top >= MSGPACK_EMBED_STACK_SIZE) { goto _failed; } /* FIXME */ \ if(msgpack_unpack_callback(func)(user, count_, &stack[top].obj) < 0) { goto _failed; } \ if((count_) == 0) { obj = stack[top].obj; goto _push; } \ stack[top].ct = ct_; \ stack[top].count = count_; \ ++top; \ /*printf("container %d count %d stack %d\n",stack[top].obj,count_,top);*/ \ /*printf("stack push %d\n", top);*/ \ /* FIXME \ if(top >= stack_size) { \ if(stack_size == MSGPACK_EMBED_STACK_SIZE) { \ size_t csize = sizeof(msgpack_unpack_struct(_stack)) * MSGPACK_EMBED_STACK_SIZE; \ size_t nsize = csize * 2; \ msgpack_unpack_struct(_stack)* tmp = (msgpack_unpack_struct(_stack)*)malloc(nsize); \ if(tmp == NULL) { goto _failed; } \ memcpy(tmp, ctx->stack, csize); \ ctx->stack = stack = tmp; \ ctx->stack_size = stack_size = MSGPACK_EMBED_STACK_SIZE * 2; \ } else { \ size_t nsize = sizeof(msgpack_unpack_struct(_stack)) * ctx->stack_size * 2; \ msgpack_unpack_struct(_stack)* tmp = (msgpack_unpack_struct(_stack)*)realloc(ctx->stack, nsize); \ if(tmp == NULL) { goto _failed; } \ ctx->stack = stack = tmp; \ ctx->stack_size = stack_size = stack_size * 2; \ } \ } \ */ \ goto _header_again #define NEXT_CS(p) \ ((unsigned int)*p & 0x1f) #ifdef USE_CASE_RANGE #define SWITCH_RANGE_BEGIN switch(*p) { #define SWITCH_RANGE(FROM, TO) case FROM ... TO: #define SWITCH_RANGE_DEFAULT default: #define SWITCH_RANGE_END } #else #define SWITCH_RANGE_BEGIN { if(0) { #define SWITCH_RANGE(FROM, TO) } else if(FROM <= *p && *p <= TO) { #define SWITCH_RANGE_DEFAULT } else { #define SWITCH_RANGE_END } } #endif if(p == pe) { goto _out; } do { switch(cs) { case CS_HEADER: SWITCH_RANGE_BEGIN SWITCH_RANGE(0x00, 0x7f) // Positive Fixnum push_fixed_value(_uint8, *(uint8_t*)p); SWITCH_RANGE(0xe0, 0xff) // Negative Fixnum push_fixed_value(_int8, *(int8_t*)p); SWITCH_RANGE(0xc0, 0xdf) // Variable switch(*p) { case 0xc0: // nil push_simple_value(_nil); //case 0xc1: // string // again_terminal_trail(NEXT_CS(p), p+1); case 0xc2: // false push_simple_value(_false); case 0xc3: // true push_simple_value(_true); //case 0xc4: //case 0xc5: //case 0xc6: //case 0xc7: //case 0xc8: //case 0xc9: case 0xca: // float case 0xcb: // double case 0xcc: // unsigned int 8 case 0xcd: // unsigned int 16 case 0xce: // unsigned int 32 case 0xcf: // unsigned int 64 case 0xd0: // signed int 8 case 0xd1: // signed int 16 case 0xd2: // signed int 32 case 0xd3: // signed int 64 again_fixed_trail(NEXT_CS(p), 1 << (((unsigned int)*p) & 0x03)); //case 0xd4: //case 0xd5: //case 0xd6: // big integer 16 //case 0xd7: // big integer 32 //case 0xd8: // big float 16 //case 0xd9: // big float 32 case 0xda: // raw 16 case 0xdb: // raw 32 case 0xdc: // array 16 case 0xdd: // array 32 case 0xde: // map 16 case 0xdf: // map 32 again_fixed_trail(NEXT_CS(p), 2 << (((unsigned int)*p) & 0x01)); default: goto _failed; } SWITCH_RANGE(0xa0, 0xbf) // FixRaw again_fixed_trail_if_zero(ACS_RAW_VALUE, ((unsigned int)*p & 0x1f), _raw_zero); SWITCH_RANGE(0x90, 0x9f) // FixArray start_container(_array, ((unsigned int)*p) & 0x0f, CT_ARRAY_ITEM); SWITCH_RANGE(0x80, 0x8f) // FixMap start_container(_map, ((unsigned int)*p) & 0x0f, CT_MAP_KEY); SWITCH_RANGE_DEFAULT goto _failed; SWITCH_RANGE_END // end CS_HEADER _fixed_trail_again: ++p; default: if((size_t)(pe - p) < trail) { goto _out; } n = p; p += trail - 1; switch(cs) { //case CS_ //case CS_ case CS_FLOAT: { union { uint32_t i; float f; } mem; mem.i = _msgpack_load32(uint32_t,n); push_fixed_value(_float, mem.f); } case CS_DOUBLE: { union { uint64_t i; double f; } mem; mem.i = _msgpack_load64(uint64_t,n); #if defined(__arm__) && !(__ARM_EABI__) // arm-oabi // https://github.com/msgpack/msgpack-perl/pull/1 mem.i = (mem.i & 0xFFFFFFFFUL) << 32UL | (mem.i >> 32UL); #endif push_fixed_value(_double, mem.f); } case CS_UINT_8: push_fixed_value(_uint8, *(uint8_t*)n); case CS_UINT_16: push_fixed_value(_uint16, _msgpack_load16(uint16_t,n)); case CS_UINT_32: push_fixed_value(_uint32, _msgpack_load32(uint32_t,n)); case CS_UINT_64: push_fixed_value(_uint64, _msgpack_load64(uint64_t,n)); case CS_INT_8: push_fixed_value(_int8, *(int8_t*)n); case CS_INT_16: push_fixed_value(_int16, _msgpack_load16(int16_t,n)); case CS_INT_32: push_fixed_value(_int32, _msgpack_load32(int32_t,n)); case CS_INT_64: push_fixed_value(_int64, _msgpack_load64(int64_t,n)); //case CS_ //case CS_ //case CS_BIG_INT_16: // again_fixed_trail_if_zero(ACS_BIG_INT_VALUE, _msgpack_load16(uint16_t,n), _big_int_zero); //case CS_BIG_INT_32: // again_fixed_trail_if_zero(ACS_BIG_INT_VALUE, _msgpack_load32(uint32_t,n), _big_int_zero); //case ACS_BIG_INT_VALUE: //_big_int_zero: // // FIXME // push_variable_value(_big_int, data, n, trail); //case CS_BIG_FLOAT_16: // again_fixed_trail_if_zero(ACS_BIG_FLOAT_VALUE, _msgpack_load16(uint16_t,n), _big_float_zero); //case CS_BIG_FLOAT_32: // again_fixed_trail_if_zero(ACS_BIG_FLOAT_VALUE, _msgpack_load32(uint32_t,n), _big_float_zero); //case ACS_BIG_FLOAT_VALUE: //_big_float_zero: // // FIXME // push_variable_value(_big_float, data, n, trail); case CS_RAW_16: again_fixed_trail_if_zero(ACS_RAW_VALUE, _msgpack_load16(uint16_t,n), _raw_zero); case CS_RAW_32: again_fixed_trail_if_zero(ACS_RAW_VALUE, _msgpack_load32(uint32_t,n), _raw_zero); case ACS_RAW_VALUE: _raw_zero: push_variable_value(_raw, data, n, trail); case CS_ARRAY_16: start_container(_array, _msgpack_load16(uint16_t,n), CT_ARRAY_ITEM); case CS_ARRAY_32: /* FIXME security guard */ start_container(_array, _msgpack_load32(uint32_t,n), CT_ARRAY_ITEM); case CS_MAP_16: start_container(_map, _msgpack_load16(uint16_t,n), CT_MAP_KEY); case CS_MAP_32: /* FIXME security guard */ start_container(_map, _msgpack_load32(uint32_t,n), CT_MAP_KEY); default: goto _failed; } } _push: if(top == 0) { goto _finish; } c = &stack[top-1]; switch(c->ct) { case CT_ARRAY_ITEM: if(msgpack_unpack_callback(_array_item)(user, &c->obj, obj) < 0) { goto _failed; } if(--c->count == 0) { obj = c->obj; --top; /*printf("stack pop %d\n", top);*/ goto _push; } goto _header_again; case CT_MAP_KEY: c->map_key = obj; c->ct = CT_MAP_VALUE; goto _header_again; case CT_MAP_VALUE: if(msgpack_unpack_callback(_map_item)(user, &c->obj, c->map_key, obj) < 0) { goto _failed; } if(--c->count == 0) { obj = c->obj; --top; /*printf("stack pop %d\n", top);*/ goto _push; } c->ct = CT_MAP_KEY; goto _header_again; default: goto _failed; } _header_again: cs = CS_HEADER; ++p; } while(p != pe); goto _out; _finish: stack[0].obj = obj; ++p; ret = 1; /*printf("-- finish --\n"); */ goto _end; _failed: /*printf("** FAILED **\n"); */ ret = -1; goto _end; _out: ret = 0; goto _end; _end: ctx->cs = cs; ctx->trail = trail; ctx->top = top; *off = p - (const unsigned char*)data; return ret; } #undef msgpack_unpack_func #undef msgpack_unpack_callback #undef msgpack_unpack_struct #undef msgpack_unpack_object #undef msgpack_unpack_user #undef push_simple_value #undef push_fixed_value #undef push_variable_value #undef again_fixed_trail #undef again_fixed_trail_if_zero #undef start_container #undef NEXT_CS Data-MessagePack-0.49/xshelper.h0000644000175000017500000000453212624050607016073 0ustar syoheisyohei/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil 0.45. */ /* =head1 NAME xshelper.h - Helper C header file for XS modules =head1 DESCRIPTION // This includes all the perl header files and ppport.h #include "xshelper.h" =head1 SEE ALSO L, where this file is distributed as a part of =head1 AUTHOR Fuji, Goro (gfx) Egfuji at cpan.orgE =head1 LISENCE Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut */ #ifdef __cplusplus extern "C" { #endif #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include #include #define NO_XSLOCKS /* for exceptions */ #include #ifdef __cplusplus } /* extern "C" */ #endif #include "ppport.h" /* portability stuff not supported by ppport.h yet */ #ifndef STATIC_INLINE /* from 5.13.4 */ # if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) # define STATIC_INLINE static inline # else # define STATIC_INLINE static # endif #endif /* STATIC_INLINE */ #ifndef __attribute__format__ #define __attribute__format__(a,b,c) /* nothing */ #endif #ifndef LIKELY /* they are just a compiler's hint */ #define LIKELY(x) (!!(x)) #define UNLIKELY(x) (!!(x)) #endif #ifndef newSVpvs_share #define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) #endif #ifndef get_cvs #define get_cvs(name, flags) get_cv(name, flags) #endif #ifndef GvNAME_get #define GvNAME_get GvNAME #endif #ifndef GvNAMELEN_get #define GvNAMELEN_get GvNAMELEN #endif #ifndef CvGV_set #define CvGV_set(cv, gv) (CvGV(cv) = (gv)) #endif /* general utility */ #if PERL_BCDVERSION >= 0x5008005 #define LooksLikeNumber(x) looks_like_number(x) #else #define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) #endif #define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) #define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) #define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) #define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) #define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) #define CALL_BOOT(name) STMT_START { \ PUSHMARK(SP); \ CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ } STMT_END Data-MessagePack-0.49/inc/0000755000175000017500000000000012624050607014635 5ustar syoheisyoheiData-MessagePack-0.49/inc/Module/0000755000175000017500000000000012624050607016062 5ustar syoheisyoheiData-MessagePack-0.49/inc/Module/Install/0000755000175000017500000000000012624050607017470 5ustar syoheisyoheiData-MessagePack-0.49/inc/Module/Install/Base.pm0000644000175000017500000000214712624050607020704 0ustar syoheisyohei#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Data-MessagePack-0.49/inc/Module/Install/AuthorTests.pm0000644000175000017500000000221512624050607022313 0ustar syoheisyohei#line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Data-MessagePack-0.49/inc/Module/Install/Fetch.pm0000644000175000017500000000462712624050607021070 0ustar syoheisyohei#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Data-MessagePack-0.49/inc/Module/Install/Can.pm0000644000175000017500000000615712624050607020540 0ustar syoheisyohei#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Data-MessagePack-0.49/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612624050607021561 0ustar syoheisyohei#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Data-MessagePack-0.49/inc/Module/Install/Win32.pm0000644000175000017500000000340312624050607020730 0ustar syoheisyohei#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Data-MessagePack-0.49/inc/Module/Install/Makefile.pm0000644000175000017500000002743712624050607021560 0ustar syoheisyohei#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Data-MessagePack-0.49/inc/Module/Install/XSUtil.pm0000644000175000017500000004570312624050607021227 0ustar syoheisyohei#line 1 package Module::Install::XSUtil; use 5.005_03; $VERSION = '0.45'; use Module::Install::Base; @ISA = qw(Module::Install::Base); use strict; use Config; use File::Spec; use File::Find; use constant _VERBOSE => $ENV{MI_VERBOSE} ? 1 : 0; my %ConfigureRequires = ( 'ExtUtils::ParseXS' => 3.18, # shipped with Perl 5.18.0 ); my %BuildRequires = ( ); my %Requires = ( 'XSLoader' => 0.02, ); my %ToInstall; my $UseC99 = 0; my $UseCplusplus = 0; sub _verbose{ print STDERR q{# }, @_, "\n"; } sub _xs_debugging{ return $ENV{XS_DEBUG} || scalar( grep{ $_ eq '-g' } @ARGV ); } sub _xs_initialize{ my($self) = @_; unless($self->{xsu_initialized}){ $self->{xsu_initialized} = 1; if(!$self->cc_available()){ warn "This distribution requires a C compiler, but it's not available, stopped.\n"; exit; } $self->configure_requires(%ConfigureRequires); $self->build_requires(%BuildRequires); $self->requires(%Requires); $self->makemaker_args->{OBJECT} = '$(O_FILES)'; $self->clean_files('$(O_FILES)'); $self->clean_files('*.stackdump') if $^O eq 'cygwin'; if($self->_xs_debugging()){ # override $Config{optimize} if(_is_msvc()){ $self->makemaker_args->{OPTIMIZE} = '-Zi'; } else{ $self->makemaker_args->{OPTIMIZE} = '-g -ggdb -g3'; } $self->cc_define('-DXS_ASSERT'); } } return; } # GNU C Compiler sub _is_gcc{ return $Config{gccversion}; } # Microsoft Visual C++ Compiler (cl.exe) sub _is_msvc{ return $Config{cc} =~ /\A cl \b /xmsi; } { my $cc_available; sub cc_available { return defined $cc_available ? $cc_available : ($cc_available = shift->can_cc()) ; } # cf. https://github.com/sjn/toolchain-site/blob/219db464af9b2f19b04fec05547ac10180a469f3/lancaster-consensus.md my $want_xs; sub want_xs { my($self, $default) = @_; return $want_xs if defined $want_xs; # you're using this module, you must want XS by default # unless PERL_ONLY is true. $default = !$ENV{PERL_ONLY} if not defined $default; foreach my $arg(@ARGV){ my ($k, $v) = split '=', $arg; # MM-style named args if ($k eq 'PUREPERL_ONLY' && defined $v) { return $want_xs = !$v; } elsif($arg eq '--pp'){ # old-style return $want_xs = 0; } elsif($arg eq '--xs'){ return $want_xs = 1; } } if ($ENV{PERL_MM_OPT}) { my($v) = $ENV{PERL_MM_OPT} =~ /\b PUREPERL_ONLY = (\S+) /xms; if (defined $v) { return $want_xs = !$v; } } return $want_xs = $default; } } sub use_ppport{ my($self, $dppp_version) = @_; return if $self->{_ppport_ok}++; $self->_xs_initialize(); my $filename = 'ppport.h'; $dppp_version ||= 3.19; # the more, the better $self->configure_requires('Devel::PPPort' => $dppp_version); $self->build_requires('Devel::PPPort' => $dppp_version); print "Writing $filename\n"; my $e = do{ local $@; eval qq{ use Devel::PPPort; Devel::PPPort::WriteFile(q{$filename}); }; $@; }; if($e){ print "Cannot create $filename because: $@\n"; } if(-e $filename){ $self->clean_files($filename); $self->cc_define('-DUSE_PPPORT'); $self->cc_append_to_inc('.'); } return; } sub use_xshelper { my($self, $opt) = @_; $self->_xs_initialize(); $self->use_ppport(); my $file = 'xshelper.h'; open my $fh, '>', $file or die "Cannot open $file for writing: $!"; print $fh $self->_xshelper_h(); close $fh or die "Cannot close $file: $!"; if(defined $opt) { if($opt eq '-clean') { $self->clean_files($file); } else { $self->realclean_files($file); } } return; } sub _gccversion { my $res = `$Config{cc} --version`; my ($version) = $res =~ /\(GCC\) ([0-9.]+)/; no warnings 'numeric', 'uninitialized'; return sprintf '%g', $version; } sub cc_warnings{ my($self) = @_; $self->_xs_initialize(); if(_is_gcc()){ $self->cc_append_to_ccflags(qw(-Wall)); my $gccversion = _gccversion(); if($gccversion >= 4.0){ $self->cc_append_to_ccflags(qw(-Wextra)); if(!($UseC99 or $UseCplusplus)) { # Note: MSVC++ doesn't support C99, # so -Wdeclaration-after-statement helps # ensure C89 specs. $self->cc_append_to_ccflags(qw(-Wdeclaration-after-statement)); } if($gccversion >= 4.1 && !$UseCplusplus) { $self->cc_append_to_ccflags(qw(-Wc++-compat)); } } else{ $self->cc_append_to_ccflags(qw(-W -Wno-comment)); } } elsif(_is_msvc()){ $self->cc_append_to_ccflags(qw(-W3)); } else{ # TODO: support other compilers } return; } sub c99_available { my($self) = @_; return 0 if not $self->cc_available(); require File::Temp; require File::Basename; my $tmpfile = File::Temp->new(SUFFIX => '.c'); $tmpfile->print(<<'C99'); // include a C99 header #include inline // a C99 keyword with C99 style comments int test_c99() { int i = 0; i++; int j = i - 1; // another C99 feature: declaration after statement return j; } C99 $tmpfile->close(); system "$Config{cc} -c " . $tmpfile->filename; (my $objname = File::Basename::basename($tmpfile->filename)) =~ s/\Q.c\E$/$Config{_o}/; unlink $objname or warn "Cannot unlink $objname (ignored): $!"; return $? == 0; } sub requires_c99 { my($self) = @_; if(!$self->c99_available) { warn "This distribution requires a C99 compiler, but $Config{cc} seems not to support C99, stopped.\n"; exit; } $self->_xs_initialize(); $UseC99 = 1; return; } sub requires_cplusplus { my($self) = @_; if(!$self->cc_available) { warn "This distribution requires a C++ compiler, but $Config{cc} seems not to support C++, stopped.\n"; exit; } $self->_xs_initialize(); $UseCplusplus = 1; return; } sub cc_append_to_inc{ my($self, @dirs) = @_; $self->_xs_initialize(); for my $dir(@dirs){ unless(-d $dir){ warn("'$dir' not found: $!\n"); } _verbose "inc: -I$dir" if _VERBOSE; } my $mm = $self->makemaker_args; my $paths = join q{ }, map{ s{\\}{\\\\}g; qq{"-I$_"} } @dirs; if($mm->{INC}){ $mm->{INC} .= q{ } . $paths; } else{ $mm->{INC} = $paths; } return; } sub cc_libs { my ($self, @libs) = @_; @libs = map{ my($name, $dir) = ref($_) eq 'ARRAY' ? @{$_} : ($_, undef); my $lib; if(defined $dir) { $lib = ($dir =~ /^-/ ? qq{$dir } : qq{-L$dir }); } else { $lib = ''; } $lib .= ($name =~ /^-/ ? qq{$name} : qq{-l$name}); _verbose "libs: $lib" if _VERBOSE; $lib; } @libs; $self->cc_append_to_libs( @libs ); } sub cc_append_to_libs{ my($self, @libs) = @_; $self->_xs_initialize(); return unless @libs; my $libs = join q{ }, @libs; my $mm = $self->makemaker_args; if ($mm->{LIBS}){ $mm->{LIBS} .= q{ } . $libs; } else{ $mm->{LIBS} = $libs; } return $libs; } sub cc_assert_lib { my ($self, @dcl_args) = @_; if ( ! $self->{xsu_loaded_checklib} ) { my $loaded_lib = 0; foreach my $checklib (qw(inc::Devel::CheckLib Devel::CheckLib)) { eval "use $checklib 0.4"; if (!$@) { $loaded_lib = 1; last; } } if (! $loaded_lib) { warn "Devel::CheckLib not found in inc/ nor \@INC"; exit 0; } $self->{xsu_loaded_checklib}++; $self->configure_requires( "Devel::CheckLib" => "0.4" ); $self->build_requires( "Devel::CheckLib" => "0.4" ); } Devel::CheckLib::check_lib_or_exit(@dcl_args); } sub cc_append_to_ccflags{ my($self, @ccflags) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; $mm->{CCFLAGS} ||= $Config{ccflags}; $mm->{CCFLAGS} .= q{ } . join q{ }, @ccflags; return; } sub cc_define{ my($self, @defines) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; if(exists $mm->{DEFINE}){ $mm->{DEFINE} .= q{ } . join q{ }, @defines; } else{ $mm->{DEFINE} = join q{ }, @defines; } return; } sub requires_xs_module { my $self = shift; return $self->requires() unless @_; $self->_xs_initialize(); my %added = $self->requires(@_); my(@inc, @libs); my $rx_lib = qr{ \. (?: lib | a) \z}xmsi; my $rx_dll = qr{ \. dll \z}xmsi; # for Cygwin while(my $module = each %added){ my $mod_basedir = File::Spec->join(split /::/, $module); my $rx_header = qr{\A ( .+ \Q$mod_basedir\E ) .+ \. h(?:pp)? \z}xmsi; SCAN_INC: foreach my $inc_dir(@INC){ my @dirs = grep{ -e } File::Spec->join($inc_dir, 'auto', $mod_basedir), File::Spec->join($inc_dir, $mod_basedir); next SCAN_INC unless @dirs; my $n_inc = scalar @inc; find(sub{ if(my($incdir) = $File::Find::name =~ $rx_header){ push @inc, $incdir; } elsif($File::Find::name =~ $rx_lib){ my($libname) = $_ =~ /\A (?:lib)? (\w+) /xmsi; push @libs, [$libname, $File::Find::dir]; } elsif($File::Find::name =~ $rx_dll){ # XXX: hack for Cygwin my $mm = $self->makemaker_args; $mm->{macro}->{PERL_ARCHIVE_AFTER} ||= ''; $mm->{macro}->{PERL_ARCHIVE_AFTER} .= ' ' . $File::Find::name; } }, @dirs); if($n_inc != scalar @inc){ last SCAN_INC; } } } my %uniq = (); $self->cc_append_to_inc (grep{ !$uniq{ $_ }++ } @inc); %uniq = (); $self->cc_libs(grep{ !$uniq{ $_->[0] }++ } @libs); return %added; } sub cc_src_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); return unless @dirs; my $mm = $self->makemaker_args; my $XS_ref = $mm->{XS} ||= {}; my $C_ref = $mm->{C} ||= []; my $_obj = $Config{_o}; my @src_files; find(sub{ if(/ \. (?: xs | c (?: c | pp | xx )? ) \z/xmsi){ # *.{xs, c, cc, cpp, cxx} push @src_files, $File::Find::name; } }, @dirs); my $xs_to = $UseCplusplus ? '.cpp' : '.c'; foreach my $src_file(@src_files){ my $c = $src_file; if($c =~ s/ \.xs \z/$xs_to/xms){ $XS_ref->{$src_file} = $c; _verbose "xs: $src_file" if _VERBOSE; } else{ _verbose "c: $c" if _VERBOSE; } push @{$C_ref}, $c unless grep{ $_ eq $c } @{$C_ref}; } $self->clean_files(map{ File::Spec->catfile($_, '*.gcov'), File::Spec->catfile($_, '*.gcda'), File::Spec->catfile($_, '*.gcno'), } @dirs); $self->cc_append_to_inc('.'); return; } sub cc_include_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); push @{ $self->{xsu_include_paths} ||= []}, @dirs; my $h_map = $self->{xsu_header_map} ||= {}; foreach my $dir(@dirs){ my $prefix = quotemeta( File::Spec->catfile($dir, '') ); find(sub{ return unless / \.h(?:pp)? \z/xms; (my $h_file = $File::Find::name) =~ s/ \A $prefix //xms; $h_map->{$h_file} = $File::Find::name; }, $dir); } $self->cc_append_to_inc(@dirs); return; } sub install_headers{ my $self = shift; my $h_files; if(@_ == 0){ $h_files = $self->{xsu_header_map} or die "install_headers: cc_include_paths not specified.\n"; } elsif(@_ == 1 && ref($_[0]) eq 'HASH'){ $h_files = $_[0]; } else{ $h_files = +{ map{ $_ => undef } @_ }; } $self->_xs_initialize(); my @not_found; my $h_map = $self->{xsu_header_map} || {}; while(my($ident, $path) = each %{$h_files}){ $path ||= $h_map->{$ident} || File::Spec->join('.', $ident); $path = File::Spec->canonpath($path); unless($path && -e $path){ push @not_found, $ident; next; } $ToInstall{$path} = File::Spec->join('$(INST_ARCHAUTODIR)', $ident); _verbose "install: $path as $ident" if _VERBOSE; my @funcs = $self->_extract_functions_from_header_file($path); if(@funcs){ $self->cc_append_to_funclist(@funcs); } } if(@not_found){ die "Header file(s) not found: @not_found\n"; } return; } my $home_directory; sub _extract_functions_from_header_file{ my($self, $h_file) = @_; my @functions; ($home_directory) = <~> unless defined $home_directory; # get header file contents through cpp(1) my $contents = do { my $mm = $self->makemaker_args; my $cppflags = q{"-I}. File::Spec->join($Config{archlib}, 'CORE') . q{"}; $cppflags =~ s/~/$home_directory/g; $cppflags .= ' ' . $mm->{INC} if $mm->{INC}; $cppflags .= ' ' . ($mm->{CCFLAGS} || $Config{ccflags}); $cppflags .= ' ' . $mm->{DEFINE} if $mm->{DEFINE}; my $add_include = _is_msvc() ? '-FI' : '-include'; $cppflags .= ' ' . join ' ', map{ qq{$add_include "$_"} } qw(EXTERN.h perl.h XSUB.h); my $cppcmd = qq{$Config{cpprun} $cppflags $h_file}; # remove all the -arch options to workaround gcc errors: # "-E, -S, -save-temps and -M options are not allowed # with multiple -arch flags" $cppcmd =~ s/ -arch \s* \S+ //xmsg; _verbose("extract functions from: $cppcmd") if _VERBOSE; `$cppcmd`; }; unless(defined $contents){ die "Cannot call C pre-processor ($Config{cpprun}): $! ($?)"; } # remove other include file contents my $chfile = q/\# (?:line)? \s+ \d+ /; $contents =~ s{ ^$chfile \s+ (?!"\Q$h_file\E") .*? ^(?= $chfile) }{}xmsig; if(_VERBOSE){ local *H; open H, "> $h_file.out" and print H $contents and close H; } while($contents =~ m{ ([^\\;\s]+ # type \s+ ([a-zA-Z_][a-zA-Z0-9_]*) # function name \s* \( [^;#]* \) # argument list [\w\s\(\)]* # attributes or something ;) # end of declaration }xmsg){ my $decl = $1; my $name = $2; next if $decl =~ /\b typedef \b/xms; next if $name =~ /^_/xms; # skip something private push @functions, $name; if(_VERBOSE){ $decl =~ tr/\n\r\t / /s; $decl =~ s/ (\Q$name\E) /<$name>/xms; _verbose("decl: $decl"); } } return @functions; } sub cc_append_to_funclist{ my($self, @functions) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; push @{$mm->{FUNCLIST} ||= []}, @functions; $mm->{DL_FUNCS} ||= { '$(NAME)' => [] }; return; } sub _xshelper_h { my $h = <<'XSHELPER_H'; :/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil $VERSION. */ :/* :=head1 NAME : :xshelper.h - Helper C header file for XS modules : :=head1 DESCRIPTION : : // This includes all the perl header files and ppport.h : #include "xshelper.h" : :=head1 SEE ALSO : :L, where this file is distributed as a part of : :=head1 AUTHOR : :Fuji, Goro (gfx) Egfuji at cpan.orgE : :=head1 LISENCE : :Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. : :This library is free software; you can redistribute it and/or modify :it under the same terms as Perl itself. : :=cut :*/ : :#ifdef __cplusplus :extern "C" { :#endif : :#define PERL_NO_GET_CONTEXT /* we want efficiency */ :#include :#include :#define NO_XSLOCKS /* for exceptions */ :#include : :#ifdef __cplusplus :} /* extern "C" */ :#endif : :#include "ppport.h" : :/* portability stuff not supported by ppport.h yet */ : :#ifndef STATIC_INLINE /* from 5.13.4 */ :# if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) :# define STATIC_INLINE static inline :# else :# define STATIC_INLINE static :# endif :#endif /* STATIC_INLINE */ : :#ifndef __attribute__format__ :#define __attribute__format__(a,b,c) /* nothing */ :#endif : :#ifndef LIKELY /* they are just a compiler's hint */ :#define LIKELY(x) (!!(x)) :#define UNLIKELY(x) (!!(x)) :#endif : :#ifndef newSVpvs_share :#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) :#endif : :#ifndef get_cvs :#define get_cvs(name, flags) get_cv(name, flags) :#endif : :#ifndef GvNAME_get :#define GvNAME_get GvNAME :#endif :#ifndef GvNAMELEN_get :#define GvNAMELEN_get GvNAMELEN :#endif : :#ifndef CvGV_set :#define CvGV_set(cv, gv) (CvGV(cv) = (gv)) :#endif : :/* general utility */ : :#if PERL_BCDVERSION >= 0x5008005 :#define LooksLikeNumber(x) looks_like_number(x) :#else :#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) :#endif : :#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) :#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) :#define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) :#define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) : :#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) :#define CALL_BOOT(name) STMT_START { \ : PUSHMARK(SP); \ : CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ : } STMT_END XSHELPER_H $h =~ s/^://xmsg; $h =~ s/\$VERSION\b/$Module::Install::XSUtil::VERSION/xms; return $h; } package MY; # XXX: We must append to PM inside ExtUtils::MakeMaker->new(). sub init_PM { my $self = shift; $self->SUPER::init_PM(@_); while(my($k, $v) = each %ToInstall){ $self->{PM}{$k} = $v; } return; } # append object file names to CCCMD sub const_cccmd { my $self = shift; my $cccmd = $self->SUPER::const_cccmd(@_); return q{} unless $cccmd; if (Module::Install::XSUtil::_is_msvc()){ $cccmd .= ' -Fo$@'; } else { $cccmd .= ' -o $@'; } return $cccmd } sub xs_c { my($self) = @_; my $mm = $self->SUPER::xs_c(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } sub xs_o { my($self) = @_; my $mm = $self->SUPER::xs_o(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } 1; __END__ #line 1030 Data-MessagePack-0.49/inc/Module/Install/Metadata.pm0000644000175000017500000004330212624050607021550 0ustar syoheisyohei#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Data-MessagePack-0.49/inc/Module/Install.pm0000644000175000017500000003021712624050607020031 0ustar syoheisyohei#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.16'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Data-MessagePack-0.49/README0000644000175000017500000001443412624045420014747 0ustar syoheisyoheiNAME Data::MessagePack - MessagePack serializing/deserializing SYNOPSIS use Data::MessagePack; my $mp = Data::MessagePack->new(); $mp->canonical->utf8->prefer_integer if $needed; my $packed = $mp->pack($dat); my $unpacked = $mp->unpack($dat); DESCRIPTION This module converts Perl data structures to MessagePack and vice versa. ABOUT MESSAGEPACK FORMAT MessagePack is a binary-based efficient object serialization format. It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small. ADVANTAGES PORTABLE The MessagePack format does not depend on language nor byte order. SMALL IN SIZE say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13 say length(Storable::nfreeze({a=>1, b=>2})); # => 21 say length(Data::MessagePack->pack({a=>1, b=>2})); # => 7 The MessagePack format saves memory than JSON and Storable format. STREAMING DESERIALIZER MessagePack supports streaming deserializer. It is useful for networking such as RPC. See Data::MessagePack::Unpacker for details. If you want to get more information about the MessagePack format, please visit to . METHODS "my $packed = Data::MessagePack->pack($data[, $max_depth]);" Pack the $data to messagepack format string. This method throws an exception when the perl structure is nested more than $max_depth levels(default: 512) in order to detect circular references. Data::MessagePack->pack() throws an exception when encountering a blessed perl object, because MessagePack is a language-independent format. "my $unpacked = Data::MessagePack->unpack($msgpackstr);" unpack the $msgpackstr to a MessagePack format string. "my $mp = Data::MesssagePack->new()" Creates a new MessagePack instance. "$mp = $mp->prefer_integer([ $enable ])" "$enabled = $mp->get_prefer_integer()" If *$enable* is true (or missing), then the "pack" method tries a string as an integer if the string looks like an integer. "$mp = $mp->canonical([ $enable ])" "$enabled = $mp->get_canonical()" If *$enable* is true (or missing), then the "pack" method will output packed data by sorting their keys. This is adding a comparatively high overhead. "$mp = $mp->utf8([ $enable ])" "$enabled = $mp->get_utf8()" If *$enable* is true (or missing), then the "pack" method will apply "utf8::encode()" to all the string values. In other words, this property tell $mp to deal with text strings. See perlunifaq for the meaning of text string. "$packed = $mp->pack($data)" "$packed = $mp->encode($data)" Same as "Data::MessagePack->pack()", but properties are respected. "$data = $mp->unpack($data)" "$data = $mp->decode($data)" Same as "Data::MessagePack->unpack()", but properties are respected. Configuration Variables (DEPRECATED) $Data::MessagePack::PreferInteger Packs a string as an integer, when it looks like an integer. This variable is deprecated. Use "$msgpack->prefer_integer" property instead. SPEED This is a result of benchmark/serialize.pl and benchmark/deserialize.pl on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). (You should benchmark them with your data if the speed matters, of course.) -- serialize JSON::XS: 2.3 Data::MessagePack: 0.24 Storable: 2.21 Benchmark: running json, mp, storable for at least 1 CPU seconds... json: 1 wallclock secs ( 1.00 usr + 0.01 sys = 1.01 CPU) @ 141939.60/s (n=143359) mp: 1 wallclock secs ( 1.06 usr + 0.00 sys = 1.06 CPU) @ 355500.94/s (n=376831) storable: 1 wallclock secs ( 1.12 usr + 0.00 sys = 1.12 CPU) @ 38399.11/s (n=43007) Rate storable json mp storable 38399/s -- -73% -89% json 141940/s 270% -- -60% mp 355501/s 826% 150% -- -- deserialize JSON::XS: 2.3 Data::MessagePack: 0.24 Storable: 2.21 Benchmark: running json, mp, storable for at least 1 CPU seconds... json: 0 wallclock secs ( 1.05 usr + 0.00 sys = 1.05 CPU) @ 179442.86/s (n=188415) mp: 0 wallclock secs ( 1.01 usr + 0.00 sys = 1.01 CPU) @ 212909.90/s (n=215039) storable: 2 wallclock secs ( 1.14 usr + 0.00 sys = 1.14 CPU) @ 114974.56/s (n=131071) Rate storable json mp storable 114975/s -- -36% -46% json 179443/s 56% -- -16% mp 212910/s 85% 19% -- CAVEAT Unpacking 64 bit integers This module can unpack 64 bit integers even if your perl does not support them (i.e. where "perl -V:ivsize" is 4), but you cannot calculate these values unless you use "Math::BigInt". TODO Error handling MessagePack cannot deal with complex scalars such as object references, filehandles, and code references. We should report the errors more kindly. Streaming deserializer The current implementation of the streaming deserializer does not have internal buffers while some other bindings (such as Ruby binding) does. This limitation will astonish those who try to unpack byte streams with an arbitrary buffer size (e.g. "while(read($socket, $buffer, $arbitrary_buffer_size)) { ... }"). We should implement the internal buffer for the unpacker. FAQ Why does Data::MessagePack have pure perl implementations? msgpack C library uses C99 feature, VC++6 does not support C99. So pure perl version is needed for VC++ users. AUTHORS Tokuhiro Matsuno Makamaka Hannyaharamitu gfx THANKS TO Jun Kuriyama Dan Kogai FURUHASHI Sadayuki hanekomu Kazuho Oku shohex LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO is the official web site for the MessagePack format. Data::MessagePack::Unpacker AnyEvent::MPRPC Data-MessagePack-0.49/lib/0000755000175000017500000000000012624050607014632 5ustar syoheisyoheiData-MessagePack-0.49/lib/Data/0000755000175000017500000000000012624050607015503 5ustar syoheisyoheiData-MessagePack-0.49/lib/Data/MessagePack/0000755000175000017500000000000012624050607017666 5ustar syoheisyoheiData-MessagePack-0.49/lib/Data/MessagePack/Unpacker.pod0000644000175000017500000000033112624045420022134 0ustar syoheisyohei=head1 NAME Data::MessagePack::Unpacker - (DEPRECATED)messagepack streaming deserializer =head1 DESCRIPTION This module was deprecated. This module have a critical issue. Use L instead. Data-MessagePack-0.49/lib/Data/MessagePack/Boolean.pm0000644000175000017500000000046712624045420021607 0ustar syoheisyoheipackage Data::MessagePack::Boolean; use strict; use warnings; use overload 'bool' => sub { ${ $_[0] } }, '0+' => sub { ${ $_[0] } }, '""' => sub { ${ $_[0] } ? 'true' : 'false' }, fallback => 1, ; our $true = do { bless \(my $dummy = 1) }; our $false = do { bless \(my $dummy = 0) }; 1; Data-MessagePack-0.49/lib/Data/MessagePack/PP.pm0000644000175000017500000004614012624045420020545 0ustar syoheisyoheipackage 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' ) { 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 = $num < 32 ? CORE::pack( 'C', 0xa0 + $num ) : $num < 2 ** 16 - 1 ? CORE::pack( 'Cn', 0xda, $num ) : $num < 2 ** 32 - 1 ? CORE::pack( 'CN', 0xdb, $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=@_)"); } sub unpack :method { $p = 0; # init $_utf8 = (ref($_[0]) && $_[0]->{utf8}) || $_utf8; my $data = _unpack( $_[1] ); if($p < length($_[1])) { Carp::croak("Data::MessagePack->unpack: extra bytes"); } return $data; } my $T_RAW = 0x01; my $T_ARRAY = 0x02; my $T_MAP = 0x04; my $T_DIRECT = 0x08; # 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_RAW for 0xa0 .. 0xbf, # fix raw 0xda, # raw16 0xdb, # raw32 ; my @byte2value; 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, $x16, $x32, $x_fixbits) = @_; if ( $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_RAW ) { my $size = _fetch_size(\$value, $byte, 0xda, 0xdb, 0xa0); my $s = substr( $value, $p, $size ); length($s) == $size or _insufficient('raw'); $p += $size; utf8::decode($s) if $_utf8; return $s; } elsif ( $typemap[$byte] & $T_ARRAY ) { my $size = _fetch_size(\$value, $byte, 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, 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 ( $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_RAW ) { my $num; if ( $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 ( $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 internally. =head1 SEE ALSO L, L, L, =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 Data-MessagePack-0.49/lib/Data/MessagePack.pm0000644000175000017500000001672012624050601020224 0ustar syoheisyoheipackage Data::MessagePack; use strict; use warnings; use 5.008001; our $VERSION = '0.49'; sub true () { require Data::MessagePack::Boolean; no warnings 'once'; return $Data::MessagePack::Boolean::true; } sub false () { require Data::MessagePack::Boolean; no warnings 'once'; return $Data::MessagePack::Boolean::false; } if ( !__PACKAGE__->can('pack') ) { # this idea comes from Text::Xslate my $backend = $ENV{PERL_DATA_MESSAGEPACK} || ($ENV{PERL_ONLY} ? 'pp' : ''); if ( $backend !~ /\b pp \b/xms ) { eval { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); }; die $@ if $@ && $backend =~ /\b xs \b/xms; # force XS } if ( !__PACKAGE__->can('pack') ) { require 'Data/MessagePack/PP.pm'; } } sub new { my($class, %args) = @_; return bless \%args, $class; } foreach my $name(qw(canonical prefer_integer utf8)) { my $setter = sub { my($self, $value) = @_; $self->{$name} = defined($value) ? $value : 1; return $self; }; my $getter = sub { my($self) = @_; return $self->{$name}; }; no strict 'refs'; *{$name} = $setter; *{'get_' . $name} = $getter; } sub encode; *encode = __PACKAGE__->can('pack'); sub decode; *decode = __PACKAGE__->can('unpack'); 1; __END__ =head1 NAME Data::MessagePack - MessagePack serializing/deserializing =head1 SYNOPSIS use Data::MessagePack; my $mp = Data::MessagePack->new(); $mp->canonical->utf8->prefer_integer if $needed; my $packed = $mp->pack($dat); my $unpacked = $mp->unpack($dat); =head1 DESCRIPTION This module converts Perl data structures to MessagePack and vice versa. =head1 ABOUT MESSAGEPACK FORMAT MessagePack is a binary-based efficient object serialization format. It enables to exchange structured objects between many languages like JSON. But unlike JSON, it is very fast and small. =head2 ADVANTAGES =over 4 =item PORTABLE The MessagePack format does not depend on language nor byte order. =item SMALL IN SIZE say length(JSON::XS::encode_json({a=>1, b=>2})); # => 13 say length(Storable::nfreeze({a=>1, b=>2})); # => 21 say length(Data::MessagePack->pack({a=>1, b=>2})); # => 7 The MessagePack format saves memory than JSON and Storable format. =item STREAMING DESERIALIZER MessagePack supports streaming deserializer. It is useful for networking such as RPC. See L for details. =back If you want to get more information about the MessagePack format, please visit to L. =head1 METHODS =over =item C<< my $packed = Data::MessagePack->pack($data[, $max_depth]); >> Pack the $data to messagepack format string. This method throws an exception when the perl structure is nested more than $max_depth levels(default: 512) in order to detect circular references. Data::MessagePack->pack() throws an exception when encountering a blessed perl object, because MessagePack is a language-independent format. =item C<< my $unpacked = Data::MessagePack->unpack($msgpackstr); >> unpack the $msgpackstr to a MessagePack format string. =item C<< my $mp = Data::MesssagePack->new() >> Creates a new MessagePack instance. =item C<< $mp = $mp->prefer_integer([ $enable ]) >> =item C<< $enabled = $mp->get_prefer_integer() >> If I<$enable> is true (or missing), then the C method tries a string as an integer if the string looks like an integer. =item C<< $mp = $mp->canonical([ $enable ]) >> =item C<< $enabled = $mp->get_canonical() >> If I<$enable> is true (or missing), then the C method will output packed data by sorting their keys. This is adding a comparatively high overhead. =item C<< $mp = $mp->utf8([ $enable ]) >> =item C<< $enabled = $mp->get_utf8() >> If I<$enable> is true (or missing), then the C method will apply C to all the string values. In other words, this property tell C<$mp> to deal with B. See L for the meaning of B. =item C<< $packed = $mp->pack($data) >> =item C<< $packed = $mp->encode($data) >> Same as C<< Data::MessagePack->pack() >>, but properties are respected. =item C<< $data = $mp->unpack($data) >> =item C<< $data = $mp->decode($data) >> Same as C<< Data::MessagePack->unpack() >>, but properties are respected. =back =head1 Configuration Variables (DEPRECATED) =over 4 =item $Data::MessagePack::PreferInteger Packs a string as an integer, when it looks like an integer. This variable is B. Use C<< $msgpack->prefer_integer >> property instead. =back =head1 SPEED This is a result of F and F on my SC440(Linux 2.6.32-23-server #37-Ubuntu SMP). (You should benchmark them with B data if the speed matters, of course.) -- serialize JSON::XS: 2.3 Data::MessagePack: 0.24 Storable: 2.21 Benchmark: running json, mp, storable for at least 1 CPU seconds... json: 1 wallclock secs ( 1.00 usr + 0.01 sys = 1.01 CPU) @ 141939.60/s (n=143359) mp: 1 wallclock secs ( 1.06 usr + 0.00 sys = 1.06 CPU) @ 355500.94/s (n=376831) storable: 1 wallclock secs ( 1.12 usr + 0.00 sys = 1.12 CPU) @ 38399.11/s (n=43007) Rate storable json mp storable 38399/s -- -73% -89% json 141940/s 270% -- -60% mp 355501/s 826% 150% -- -- deserialize JSON::XS: 2.3 Data::MessagePack: 0.24 Storable: 2.21 Benchmark: running json, mp, storable for at least 1 CPU seconds... json: 0 wallclock secs ( 1.05 usr + 0.00 sys = 1.05 CPU) @ 179442.86/s (n=188415) mp: 0 wallclock secs ( 1.01 usr + 0.00 sys = 1.01 CPU) @ 212909.90/s (n=215039) storable: 2 wallclock secs ( 1.14 usr + 0.00 sys = 1.14 CPU) @ 114974.56/s (n=131071) Rate storable json mp storable 114975/s -- -36% -46% json 179443/s 56% -- -16% mp 212910/s 85% 19% -- =head1 CAVEAT =head2 Unpacking 64 bit integers This module can unpack 64 bit integers even if your perl does not support them (i.e. where C<< perl -V:ivsize >> is 4), but you cannot calculate these values unless you use C. =head1 TODO =over =item Error handling MessagePack cannot deal with complex scalars such as object references, filehandles, and code references. We should report the errors more kindly. =item Streaming deserializer The current implementation of the streaming deserializer does not have internal buffers while some other bindings (such as Ruby binding) does. This limitation will astonish those who try to unpack byte streams with an arbitrary buffer size (e.g. C<< while(read($socket, $buffer, $arbitrary_buffer_size)) { ... } >>). We should implement the internal buffer for the unpacker. =back =head1 FAQ =over 4 =item Why does Data::MessagePack have pure perl implementations? msgpack C library uses C99 feature, VC++6 does not support C99. So pure perl version is needed for VC++ users. =back =head1 AUTHORS Tokuhiro Matsuno Makamaka Hannyaharamitu gfx =head1 THANKS TO Jun Kuriyama Dan Kogai FURUHASHI Sadayuki hanekomu Kazuho Oku shohex =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L is the official web site for the MessagePack format. L L =cut Data-MessagePack-0.49/t/0000755000175000017500000000000012624050607014327 5ustar syoheisyoheiData-MessagePack-0.49/t/09_stddata.t0000644000175000017500000000161712624045420016452 0ustar syoheisyohei#!perl -w # Testing standard dataset in msgpack/test/*.{json,mpac}. # Don't edit msgpack/perl/t/std/*, which are just copies. use strict; use Test::More; use t::Util; use Data::MessagePack; sub slurp { open my $fh, '<:raw', $_[0] or die "failed to open '$_[0]': $!"; local $/; return scalar <$fh>; } my @data = do { my $json = slurp("t/std/cases.json"); $json =~ s/:/=>/g; @{ eval $json }; }; my $mpac1 = slurp("t/std/cases.mpac"); my $mpac2 = slurp("t/std/cases_compact.mpac"); my $mps = Data::MessagePack::Unpacker->new(); my $t = 1; for my $mpac($mpac1, $mpac2) { note "mpac", $t++; my $offset = 0; my $i = 0; while($offset < length($mpac)) { $offset = $mps->execute($mpac, $offset); ok $mps->is_finished, "data[$i] : is_finished"; is_deeply $mps->data, $data[$i], "data[$i]"; $mps->reset; $i++; } } done_testing; Data-MessagePack-0.49/t/11_stream_unpack3.t0000644000175000017500000000131512624045420017731 0ustar syoheisyoheiuse strict; use warnings; use Test::More; use Data::MessagePack; my @data = ( [ 1, 2, 3 ], [ 4, 5, 6 ] ); # serialize my $buffer = ''; for my $d (@data) { $buffer .= Data::MessagePack->pack($d); } # deserialize my $cb = sub { my ($data) = @_; my $d = shift @data; is_deeply $data, $d; }; my $unpacker = Data::MessagePack::Unpacker->new(); my $nread = 0; while (1) { $nread = $unpacker->execute( $buffer, $nread ); if ( $unpacker->is_finished ) { my $ret = $unpacker->data; $cb->( $ret ); $unpacker->reset; $buffer = substr( $buffer, $nread ); $nread = 0; next if length($buffer) != 0; } last; } is scalar(@data), 0; done_testing; Data-MessagePack-0.49/t/03_stream_unpack.t0000644000175000017500000000162012624045420017646 0ustar syoheisyoheiuse t::Util; use Test::More; use Data::MessagePack; no warnings 'uninitialized'; # i need this. i need this. my $up = Data::MessagePack::Unpacker->new; sub unpackit { my $v = $_[0]; $v =~ s/ //g; $v = pack 'H*', $v; $up->reset; my $ret = $up->execute($v, 0); if ($ret != length($v)) { fail "extra bytes"; } return $up->data; } sub pis ($$) { is_deeply unpackit($_[0]), $_[1], 'dump ' . $_[0]; } my @dat = do 't/data.pl'; plan tests => 1*(scalar(@dat)/2) + 3; isa_ok $up, 'Data::MessagePack::Unpacker'; for (my $i=0; $inew(); $up->execute("\x95", 0); # array marker for (1..5) { $up->execute("\xc0", 0); # nil } ok $up->is_finished, 'finished'; is_deeply $up->data, [undef, undef, undef, undef, undef], 'array, is_deeply'; } Data-MessagePack-0.49/t/20_de.t0000644000175000017500000000141712624045420015405 0ustar syoheisyohei#!perl # from Data::Encoder's msgpack driver tests use strict; use warnings; use Config; use if $Config{nvsize} > 8, 'Test::More', skip_all => 'long double is not supported'; use Test::More; use Data::MessagePack; sub d { my($dm, $value) = @_; my $binary = $dm->encode($value); diag('binary: ', join ' ', map { sprintf '%02X', ord $_ } split //, $binary); } my $dm = Data::MessagePack->new( utf8 => 1, prefer_integer => 1, canonical => 1, ); my $d = { a => 0.11, b => "\x{3042}" }; is_deeply $dm->decode( $dm->encode($d) ), $d; is $dm->decode( $dm->encode(0.1) ), 0.1 or d($dm, 0.1); is $dm->decode( $dm->encode(0.11) ), 0.11 or d($dm, 0.11); is $dm->decode( $dm->encode(0.111) ), 0.111 or d($dm, 0.111); done_testing; Data-MessagePack-0.49/t/16_unpacker_for_larges.t0000644000175000017500000000073112624045420021033 0ustar syoheisyoheiuse strict; use Test::More; use Data::MessagePack; foreach my $data("abc", [ 'x' x 1024 ], [0xFFFF42]) { my $packed = Data::MessagePack->pack($data); my $unpacker = Data::MessagePack::Unpacker->new; note "buff: ", join " ", map { unpack 'H2', $_ } split //, $packed; foreach my $byte(split //, $packed) { $unpacker->execute($byte); } ok $unpacker->is_finished, 'finished'; is_deeply $unpacker->data, $data, 'data'; } done_testing; Data-MessagePack-0.49/t/10_splitted_bytes.t0000644000175000017500000000175212624045420020054 0ustar syoheisyohei#!perl # This feature is not yet supported, but 0.23 (or former) caused SEGV in this code, # so we put it here. use strict; use warnings; use Data::MessagePack; use Test::More; use t::Util; my $input = [ false,true,null,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1, 127,127,255,65535,4294967295,-32,-32,-128,-32768, -2147483648,0.0,-0.0,1.0,-1.0,"a","a","a","","","", [0],[0],[0],[],[],[],{},{},{}, {"a" => 97},{"a" => 97},{"a" => 97},[[]],[["a"]] ]; my $packed = Data::MessagePack->pack($input); foreach my $size(1 .. 16) { my $up = Data::MessagePack::Unpacker->new(); open my $stream, '<:bytes :scalar', \$packed; binmode $stream; my $buff; my $done = 0; while( read($stream, $buff, $size) ) { note "buff: ", join " ", map { unpack 'H2', $_ } split //, $buff; $done = $up->execute($buff); } is $done, length($packed); ok $up->is_finished, "is_finished: $size"; my $data = $up->data; is_deeply $data, $input; } done_testing; Data-MessagePack-0.49/t/02_unpack.t0000644000175000017500000000110012624045420016263 0ustar syoheisyoheiuse Test::More; use Data::MessagePack; use t::Util; no warnings 'uninitialized'; # i need this. i need this. sub unpackit { my $v = $_[0]; $v =~ s/ +//g; $v = pack 'H*', $v; return Data::MessagePack->unpack($v); } sub pis ($$) { is_deeply unpackit($_[0]), $_[1], 'dump ' . $_[0] or do { diag( 'got:', explain(unpackit($_[0])) ); diag( 'expected:', explain($_[1]) ); }; } my @dat = do 't/data.pl' or die $@; plan tests => 1*(scalar(@dat)/2); for (my $i=0; $inew; isnt $mp->unpack( $mp->pack('ã¯ã‚ーï¼ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ãƒ‘ックï¼') ), 'ã¯ã‚ーï¼ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ãƒ‘ックï¼'; $mp->utf8(1); is $mp->unpack( $mp->pack('ã¯ã‚ーï¼ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ãƒ‘ックï¼') ), 'ã¯ã‚ーï¼ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ãƒ‘ックï¼'; } { my $mp = Data::MessagePack->new()->utf8(); my $latin1 = chr(233); # eacute my $s = $mp->unpack( $mp->pack($latin1) ); is $s, $latin1; is ord($s), ord($latin1); } done_testing; Data-MessagePack-0.49/t/17_canonical.t0000644000175000017500000000107412624045420016751 0ustar syoheisyohei use strict; use warnings; use Test::More; use Data::MessagePack; my $mp = Data::MessagePack->new(canonical => 1); my $data = { 'foo' => { 'a' => '', 'b' => '', 'c' => '', 'd' => '', 'e' => '', 'f' => '', 'g' => '', } }; my $packed1 = $mp->pack($data); my $packed2 = $mp->pack($mp->unpack($packed1)); my $packed3 = $mp->pack($mp->unpack($packed2)); my $packed4 = $mp->pack($mp->unpack($packed3)); my $packed5 = $mp->pack($mp->unpack($packed4)); is $packed1, $packed2; is $packed1, $packed3; is $packed1, $packed4; is $packed1, $packed5; done_testing; Data-MessagePack-0.49/t/21_dirty_float.t0000644000175000017500000000056112624045420017335 0ustar syoheisyohei#!perl use strict; use Config; use if $Config{nvsize} > 8, 'Test::More', skip_all => 'long double is not supported'; use Test::More; use Data::MessagePack; my $mp = Data::MessagePack->new(); foreach my $float(0.123, 3.14) { is $mp->unpack($mp->pack($float)), $float; scalar( $float > 0 ); is $mp->unpack($mp->pack($float)), $float; } done_testing; Data-MessagePack-0.49/t/06_stream_unpack2.t0000644000175000017500000000312612624045420017736 0ustar syoheisyoheiuse strict; use warnings; use Data::MessagePack; use Test::More tests => 64; use t::Util; my $input = [ false,true,null,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1, 127,127,255,65535,4294967295,-32,-32,-128,-32768, -2147483648,0.0,-0.0, 3.0,-3.0,"a","a",("a" x 70000),"","","", [0],[0],[0],[],[],[],{},{},{}, {"a" => 97},{"abc" => 97},{"xyz" => 97},[[]], [["foo"], ["bar"]], [["foo", true, false, null, 42]], ]; my $packed = Data::MessagePack->pack($input); is_deeply(Data::MessagePack->unpack($packed), $input); { my $up = Data::MessagePack::Unpacker->new(); $up->execute($packed, 0); ok $up->is_finished; is_deeply $up->data, $input; } { my $up = Data::MessagePack::Unpacker->new(); $packed x= 3; my $offset = 0; for my $i(1 .. 3) { note "block $i (offset: $offset/".length($packed).")"; note "starting 3 bytes: ", join " ", map { unpack 'H2', $_ } split //, substr($packed, $offset, 3); $offset = $up->execute($packed, $offset); ok $up->is_finished, 'finished'; my $data = $up->data; is scalar(@{$data}), scalar(@{$input}), 'size of @{$data}'; is_deeply $data, $input, "block $i, offset $offset"; $up->reset(); } } { my $s = ''; foreach my $datum(reverse @{$input}) { $s .= Data::MessagePack->pack($datum); } my $up = Data::MessagePack::Unpacker->new(); my $offset = 0; for my $datum(reverse @{$input}) { $offset = $up->execute($s, $offset); is_deeply $up->data, $datum, "offset $offset/" . length($s); $up->reset(); } } Data-MessagePack-0.49/t/04_invert.t0000644000175000017500000000063312624045420016325 0ustar syoheisyoheiuse Test::More; use Data::MessagePack; use t::Util; no warnings 'uninitialized'; # i need this. i need this. sub invert { return Data::MessagePack->unpack( Data::MessagePack->pack($_[0]), ); } sub pis ($) { is_deeply invert($_[0]), $_[0], 'dump ' . $_[0]; } my @dat = do 't/data.pl'; plan tests => 1*(scalar(@dat)/2); for (my $i=0; $ipack(undef); my @data = do 't/data.pl'; while(my($dump, $data) = splice @data, 0, 2) { my $s = Data::MessagePack->pack($data); eval { Data::MessagePack->unpack($s . $nil); }; like $@, qr/extra bytes/, "dump $dump"; } done_testing; Data-MessagePack-0.49/t/23-empty-key.t0000644000175000017500000000164612624045420016666 0ustar syoheisyohei#!perl # -*- perl -*- use strict; use warnings; use Test::More tests => 3; local $TODO = "not yet"; my @orig = ( ["ZZZ",{"10000050C2400102" => {"1332129147" => ["\x01\x07\x07 \xf7","2.48292"]}}], ["ZZZ",{"" => {}}], ); use Data::MessagePack; my $mp = Data::MessagePack->new(); # Just to be sure Data::MessagePack is OK for (@orig) { is_deeply(Data::MessagePack->unpack(Data::MessagePack->pack($_)), $_); } # Now test the stream... my $buf; for (@orig) { $buf .= Data::MessagePack->pack($_); } my $up = Data::MessagePack::Unpacker->new; my @res; my $offset = $up->execute($buf, 0); if ($up->is_finished) { push(@res, $up->data); $up->execute($buf, $offset); if ($up->is_finished) { push(@res, $up->data); is_deeply(\@res, \@orig) or diag(explain([\@res, \@orig])); } else { fail('Unpack second item'); } } else { fail('Unpack first item'); } Data-MessagePack-0.49/t/data.pl0000644000175000017500000000537312624045420015602 0ustar syoheisyoheino warnings; # i need this, i need this. ( '93 c0 c2 c3' => [undef, false, true], '94 a0 a1 61 a2 62 63 a3 64 65 66', ["", "a", "bc", "def"], '92 90 91 91 c0', [[], [[undef]]], '93 c0 c2 c3', [undef, false, true], '82 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # fix map 'de 00 02 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # map 16 'df 00 00 00 02 d0 2a c2 d0 2b c3', { 42 => false, 43 => true }, # map 32 'ce 80 00 00 00', 2147483648, '99 cc 00 cc 80 cc ff cd 00 00 cd 80 00 cd ff ff ce 00 00 00 00 ce 80 00 00 00 ce ff ff ff ff', [0, 128, 255, 0, 32768, 65535, 0, 2147483648, 4294967295], '92 93 00 40 7f 93 e0 f0 ff', [[0, 64, 127], [-32, -16, -1]], '96 dc 00 00 dc 00 01 c0 dc 00 02 c2 c3 dd 00 00 00 00 dd 00 00 00 01 c0 dd 00 00 00 02 c2 c3', [[], [undef], [false, true], [], [undef], [false, true]], '96 da 00 00 da 00 01 61 da 00 02 61 62 db 00 00 00 00 db 00 00 00 01 61 db 00 00 00 02 61 62', ["", "a", "ab", "", "a", "ab"], '99 d0 00 d0 80 d0 ff d1 00 00 d1 80 00 d1 ff ff d2 00 00 00 00 d2 80 00 00 00 d2 ff ff ff ff', [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1], '82 c2 81 c0 c0 c3 81 c0 80', {false,{undef,undef}, true,{undef,{}}}, '96 de 00 00 de 00 01 c0 c2 de 00 02 c0 c2 c3 c2 df 00 00 00 00 df 00 00 00 01 c0 c2 df 00 00 00 02 c0 c2 c3 c2', [{}, {undef,false}, {true,false, undef,false}, {}, {undef,false}, {true,false, undef,false}], 'dc 01 00' . (' c0' x 0x0100), [(undef) x 0x0100], 'ce 00 ff ff ff' => ''.0xFFFFFF, 'aa 34 32 39 34 39 36 37 32 39 35' => ''.0xFFFFFFFF, 'ab 36 38 37 31 39 34 37 36 37 33 35' => ''.0xFFFFFFFFF, 'ca 00 00 00 00' => 0.0, # float 'ca 40 2c cc cd' => unpack('f', pack 'f', 2.7), 'cb 3f f0 00 00 00 00 00 00' => 1.0, # double 'd2 80 00 00 01' => '-2147483647', # int32_t 'ce 80 00 00 01' => '2147483649', # uint32_t 'd2 ff ff ff ff' => '-1', # int32_t 'ce ff ff ff ff' => '4294967295', # uint32_t 'd3 00 00 00 00 80 00 00 01' => '2147483649', # int64_t 'cf 00 00 00 00 80 00 00 01' => '2147483649', # uint64_t 'd3 ff 00 ff ff ff ff ff ff' => '-71776119061217281', # int64_t 'cf ff 00 ff ff ff ff ff ff' => '18374967954648334335', # uint64_t 'd3 ff ff ff ff ff ff ff ff' => '-1', # int64_t 'cf ff ff ff ff ff ff ff ff' => '18446744073709551615', # uint64_t # int64_t 'd3 00 00 00 10 00 00 00 00' => '68719476736', 'd3 00 00 00 10 00 00 00 01' => '68719476737', 'd3 00 00 10 00 00 00 00 00' => '17592186044416', 'd3 00 10 00 00 00 00 00 00' => '4503599627370496', 'd3 10 00 00 00 00 00 00 00' => '1152921504606846976', 'd3 11 00 00 00 00 00 00 00' => '1224979098644774912', ) Data-MessagePack-0.49/t/std/0000755000175000017500000000000012624050607015121 5ustar syoheisyoheiData-MessagePack-0.49/t/std/cases.json0000644000175000017500000000033412624050607017112 0ustar syoheisyohei[false,true,null,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1,-1,127,127,255,65535,4294967295,-32,-32,-128,-32768,-2147483648,0.0,-0.0,1.0,-1.0,"a","a","a","","","",[0],[0],[0],[],[],[],{},{},{},{"a":97},{"a":97},{"a":97},[[]],[["a"]]]Data-MessagePack-0.49/t/std/cases.mpac0000644000175000017500000000032512624050607017061 0ustar syoheisyoheiÂÃÀÌÍÎÏÐÑÒÓÿÐÿÑÿÿÒÿÿÿÿÓÿÿÿÿÿÿÿÿÌÍÿÎÿÿÏÿÿÿÿàÐàÑÿ€Òÿÿ€Óÿÿÿÿ€ËË€Ë?ðË¿ð¡aÚaÛa ÚÛ‘ÜÝÜÝ€Þß¡aaÞ¡aaß¡aa‘‘‘¡aData-MessagePack-0.49/t/std/cases_compact.mpac0000644000175000017500000000016412624050607020570 0ustar syoheisyoheiÂÃÀÿÿÿÿÿÌÿÍÿÿÎÿÿÿÿààЀрҀËË€Ë?ðË¿ð¡a¡a¡a   ‘‘‘€€€¡aa¡aa¡aa‘‘‘¡aData-MessagePack-0.49/t/50_leaktrace.t0000644000175000017500000000207212624045420016751 0ustar syoheisyohei#!perl -w use strict; use Test::Requires { 'Test::LeakTrace' => 0.13 }; use Test::More; use Data::MessagePack; BEGIN { if($INC{'Data/MessagePack/PP.pm'}) { plan skip_all => 'disabled in PP'; } } my $simple_data = "xyz"; my $complex_data = { a => 'foo', b => 42, c => undef, d => [qw(bar baz)], e => 3.14, }; note 'pack'; no_leaks_ok { my $s = Data::MessagePack->pack($complex_data); }; no_leaks_ok { eval { Data::MessagePack->pack([\*STDIN]) }; note $@; $@ or warn "# it must die"; }; note 'unpack'; my $s = Data::MessagePack->pack($simple_data); my $c = Data::MessagePack->pack($complex_data); no_leaks_ok { my $data = Data::MessagePack->unpack($s); }; no_leaks_ok { my $data = Data::MessagePack->unpack($c); }; no_leaks_ok { my $broken = $s; chop $broken; eval { Data::MessagePack->unpack($broken) }; note $@; $@ or warn "# it must die"; }; note 'stream'; no_leaks_ok { my $up = Data::MessagePack::Unpacker->new(); $up->execute($c); my $data = $up->data(); }; done_testing; Data-MessagePack-0.49/t/01_pack.t0000644000175000017500000000413212624045420015727 0ustar syoheisyoheiuse t::Util; use Test::More; use Data::MessagePack; if ($] >= 5.019) { require Scalar::Util; } sub packit { local $_ = unpack("H*", Data::MessagePack->pack($_[0])); s/(..)/$1 /g; s/ $//; $_; } sub pis ($$) { is packit($_[0]), $_[1], 'dump ' . $_[1]; } my @dat = ( 0, '00', (my $foo="0")+0, '00', {2 => undef}, '81 a1 32 c0', do {no warnings; my $foo = 10; "$foo"; $foo = undef; $foo} => 'c0', # PVIV but !POK && !IOK 1, '01', 127, '7f', 128, 'cc 80', 255, 'cc ff', 256, 'cd 01 00', 65535, 'cd ff ff', 65536, 'ce 00 01 00 00', -1, 'ff', -32, 'e0', -33, 'd0 df', -128, 'd0 80', -129, 'd1 ff 7f', -32768, 'd1 80 00', -32769, 'd2 ff ff 7f ff', 1.0, 'cb 3f f0 00 00 00 00 00 00', $] < 5.019 ? do { my $x=3.0;my $y = "$x";$x } : Scalar::Util::dualvar(3.0,"3"), 'a1 33', # PVNV do { my $x=3; my $y = "$x";$x }, 'a1 33', # PVIV "", 'a0', "a", 'a1 61', "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", 'bf 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61', "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", 'da 00 20 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61 61', undef, 'c0', Data::MessagePack::true(), 'c3', Data::MessagePack::false(), 'c2', [], '90', [+[]], '91 90', [[], undef], '92 90 c0', {'a', 0}, '81 a1 61 00', 8388608, 'ce 00 80 00 00', [undef, false, true], '93 c0 c2 c3', ["", "a", "bc", "def"], '94 a0 a1 61 a2 62 63 a3 64 65 66', [[], [[undef]]], '92 90 91 91 c0', [undef, false, true], '93 c0 c2 c3', [[0, 64, 127], [-32, -16, -1]], '92 93 00 40 7f 93 e0 f0 ff', [0, -128, -1, 0, -32768, -1, 0, -2147483648, -1], '99 00 d0 80 ff 00 d1 80 00 ff 00 d2 80 00 00 00 ff', 2147483648, 'ce 80 00 00 00', -2147483648, 'd2 80 00 00 00', 'a' x 0x0100, 'da 01 00' . (' 61' x 0x0100), [(undef) x 0x0100], 'dc 01 00' . (' c0' x 0x0100), ); plan tests => 1*(scalar(@dat)/2); for (my $i=0; $i 1; use Config; use_ok 'Data::MessagePack'; diag ( "Testing Data::MessagePack/$Data::MessagePack::VERSION (", $INC{'Data/MessagePack/PP.pm'} ? 'PP' : 'XS', ")" ); diag "byteoder: $Config{byteorder}, ivsize=$Config{ivsize}"; Data-MessagePack-0.49/t/18_new_interface.t0000644000175000017500000000066012624045420017634 0ustar syoheisyohei#!perl use strict; use warnings; use Test::More; use Data::MessagePack; my $mp = Data::MessagePack->new(); is_deeply $mp->decode( $mp->encode([1, 2, 3]) ), [1, 2, 3]; my $mpc = Data::MessagePack->new->prefer_integer->canonical; ok !$mp->get_prefer_integer; ok $mpc->get_prefer_integer; ok !$mp->get_canonical; ok $mpc->get_canonical; isnt $mp->pack("42"), $mp->pack(42); is $mpc->pack("42"), $mpc->pack(42); done_testing; Data-MessagePack-0.49/t/Util.pm0000644000175000017500000000050112624045420015573 0ustar syoheisyoheipackage t::Util; use strict; use warnings; use Data::MessagePack; sub import { my $pkg = caller(0); strict->import; warnings->import; no strict 'refs'; *{"$pkg\::true"} = \&Data::MessagePack::true; *{"$pkg\::false"} = \&Data::MessagePack::false; *{"$pkg\::null"} = sub() { undef }; } 1; Data-MessagePack-0.49/t/13_booleans.t0000755000175000017500000000061312624045420016621 0ustar syoheisyohei#!perl -w use strict; use Test::More tests => 6; use Data::MessagePack; ok defined(Data::MessagePack::true()), 'true (1)'; ok defined(Data::MessagePack::true()), 'true (2)'; ok Data::MessagePack::true(), 'true is true'; ok defined(Data::MessagePack::false()), 'false (1)'; ok defined(Data::MessagePack::false()), 'false (2)'; ok !Data::MessagePack::false(), 'false is false'; Data-MessagePack-0.49/t/22_pid_pack_unpack.t0000755000175000017500000000033612624045420020134 0ustar syoheisyohei#!perl use strict; use warnings; use Test::More tests => 1; use Data::MessagePack; my $mp = Data::MessagePack->new(); is( $mp->unpack($mp->pack($$)), $$, 'pack then unpack of $$ returns same number' ); done_testing(); Data-MessagePack-0.49/t/24_tied.t0000644000175000017500000000405312624045420015745 0ustar syoheisyoheiuse t::Util; use Test::More tests => 8; use Data::MessagePack; require Tie::Hash; require Tie::Array; my (%hash, @array); tie( %hash, 'Tie::StdHash' ); %hash = ( 'module' => 'DiskUsage', 'func' => 'fetchdiskusagewithextras', 'apiversion' => '2', ); { my $mp = Data::MessagePack->new(); my $packed = eval { $mp->pack( \%hash ); }; ok(unpack("C", substr($packed,0,1)) == 0x83, "pack a tied FixMap with 3 elems"); #diag unpack("CC", substr($packed,0,2)),$packed; my $unpacked = eval { $mp->unpack( $packed ); }; if ($@) { ok( 0, "unpack tied hash" ); } else { is_deeply( \%hash, $unpacked, "round trip tied hash" ); } } { local $ENV{PERL_DATA_MESSAGEPACK} = 'pp'; my $mp = Data::MessagePack->new(); my $packed = eval { $mp->pack( \%hash ); }; ok(unpack("C", substr($packed,0,1)) == 0x83, "PP pack a tied FixMap with 3 elems"); #diag unpack("CC", substr($packed,0,2)),$packed; my $unpacked = eval { $mp->unpack( $packed ); }; if ($@) { ok( 0, "PP unpack tied hash" ); } else { is_deeply( \%hash, $unpacked, "PP round trip tied hash" ); } } tie( @array, 'Tie::StdArray' ); @array = (0..9); { my $mp = Data::MessagePack->new(); my $packed = eval { $mp->pack( \@array ); }; ok(unpack("C", substr($packed,0,1)) == 0x9a, "pack a tied FixArray with 10 elems"); #diag unpack("C", substr($packed,0,2)),$packed; my $unpacked = eval { $mp->unpack( $packed ); }; if ($@) { ok( 0, "unpack tied array" ); } else { is_deeply( \@array, $unpacked, "round trip tied array" ); } } { local $ENV{PERL_DATA_MESSAGEPACK} = 'pp'; my $mp = Data::MessagePack->new(); my $packed = eval { $mp->pack( \@array ); }; ok(unpack("C", substr($packed,0,1)) == 0x9a, "PP pack a tied FixArray with 10 elems"); #diag unpack("C", substr($packed,0,2)),$packed; my $unpacked = eval { $mp->unpack( $packed ); }; if ($@) { ok( 0, "PP unpack tied array" ); } else { is_deeply( \@array, $unpacked, "PP round trip tied array" ); } } Data-MessagePack-0.49/t/15_utf8.t0000644000175000017500000000120712624045420015704 0ustar syoheisyohei#!perl -w use strict; use Test::More; use Data::MessagePack; use utf8; my $data = [42, undef, 'foo', "\x{99f1}\x{99dd}"]; my $packed = Data::MessagePack->pack($data) x 2; my $u = Data::MessagePack::Unpacker->new()->utf8(); my $p = 0; for(1 .. 2) { ok $u->get_utf8(); $p = $u->execute($packed, $p); my $d = $u->data(); $u->reset(); is_deeply $d, $data, 'decoded'; } is $u->utf8(0), $u, 'utf8(0)'; $p = 0; for(1 .. 2) { ok !$u->get_utf8(); $p = $u->execute($packed, $p); my $d = $u->data(); $u->reset(); my $s = $data->[3]; utf8::encode($s); is_deeply $d->[3], $s, 'not decoded'; } done_testing; Data-MessagePack-0.49/t/05_preferred_int.t0000644000175000017500000000460212624045420017647 0ustar syoheisyoheiuse t::Util; use Test::More; use Data::MessagePack; use Data::Dumper; no warnings; # shut up "Integer overflow in hexadecimal number" sub packit { local $_ = unpack("H*", Data::MessagePack->pack($_[0])); s/(..)/$1 /g; s/ $//; $_; } sub pis ($$) { if (ref $_[1]) { like packit($_[0]), $_[1], 'dump ' . $_[1]; } else { is packit($_[0]), $_[1], 'dump ' . $_[1]; } # is(Dumper(Data::MessagePack->unpack(Data::MessagePack->pack($_[0]))), Dumper($_[0])); } my $is_win = $^O eq 'MSWin32'; my @dat = ( '', 'a0', '0', '00', '1', '01', '10', '0a', '-1', 'ff', '-10', 'f6', '-', 'a1 2d', ''.0xEFFF => 'cd ef ff', ''.0xFFFF => 'cd ff ff', ''.0xFFFFFF => 'ce 00 ff ff ff', ''.0xFFFFFFFF => 'ce ff ff ff ff', ''.0xFFFFFFFFF => 'ab 36 38 37 31 39 34 37 36 37 33 35', ''.0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFF => $is_win ? qr{^(b5 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 30 33 34|b8 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 34 32 31 65 2b 30 33 34)$} : qr{^(b4 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 65 2b 33 34|b7 38 2e 33 30 37 36 37 34 39 37 33 36 35 35 37 32 34 32 31 65 2b 33 34)$}, '-'.0x8000000 => 'd2 f8 00 00 00', '-'.0x80000000 => 'd2 80 00 00 00', '-'.0x800000000 => 'ac 2d 33 34 33 35 39 37 33 38 33 36 38', '-'.0x8000000000 => 'ad 2d 35 34 39 37 35 35 38 31 33 38 38 38', '-'.0x800000000000000000000000000000 => $is_win ? qr{^(b6 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 30 33 35|b9 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 37 39 33 36 65 2b 30 33 35)} : qr{^(b5 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 38 65 2b 33 35|b8 2d 36 2e 36 34 36 31 33 39 39 37 38 39 32 34 35 37 39 33 36 65 2b 33 35)}, {'0' => '1'}, '81 00 01', {'abc' => '1'}, '81 a3 61 62 63 01', ); plan tests => 1*(scalar(@dat)/2) + 2; for (my $i=0; $i 4; my $d = Data::MessagePack->unpack(Data::MessagePack->pack({ nil => undef, true => true, false => false, foo => [undef, true, false], })); $d->{nil} = 42; is $d->{nil}, 42; $d->{true} = 43; is $d->{true}, 43; $d->{false} = 44; is $d->{false}, 44; is_deeply $d->{foo}, [undef, true, false]; Data-MessagePack-0.49/t/08_cycle.t0000644000175000017500000000074612624045420016126 0ustar syoheisyoheiuse t::Util; use Test::More; use Data::MessagePack; plan tests => 6; my $aref = [0]; $aref->[1] = $aref; eval { Data::MessagePack->pack($aref) }; ok $@, $@; my $href = {}; $href->{cycle} = $href; eval { Data::MessagePack->pack($aref) }; ok $@, $@; $aref = [0,[1,2]]; eval { Data::MessagePack->pack($aref) }; ok !$@; eval { Data::MessagePack->pack($aref, 3) }; ok !$@; eval { Data::MessagePack->pack($aref, 2) }; ok $@, $@; eval { Data::MessagePack->pack($aref, -1) }; ok $@, $@; Data-MessagePack-0.49/t/40_threads.t0000644000175000017500000000133412624045420016447 0ustar syoheisyohei#!perl use strict; use warnings; use constant HAS_THREADS => eval { require threads }; use if !HAS_THREADS, 'Test::More', skip_all => 'no threads'; use Test::More; use Data::MessagePack; my $true = Data::MessagePack->unpack("\xc3"); my $false = Data::MessagePack->unpack("\xc2"); ok $true; ok !$false; threads->create(sub { my $T = Data::MessagePack->unpack("\xc3"); my $F = Data::MessagePack->unpack("\xc2"); ok $T; ok !$F; is_deeply $T, $true; is_deeply $F, $false; })->join(); $Data::MessagePack::PreferInteger = 0; threads->create(sub{ $Data::MessagePack::PreferInteger = 1; })->join(); is $Data::MessagePack::PreferInteger, 0, '$PreferInteger is a thread-local variable'; done_testing; Data-MessagePack-0.49/t/12_stream_unpack4.t0000644000175000017500000000105212624045420017731 0ustar syoheisyoheiuse strict; use warnings; use Data::MessagePack; use Test::More; use t::Util; my @input = ( [[]], [[],[]], [{"a" => 97},{"a" => 97}], [{"a" => 97},{"a" => 97},{"a" => 97}], [ map { +{ "foo $_" => "bar $_" } } 'aa' .. 'zz' ], [42, null], [42, true], [42, false], ); plan tests => @input * 2; for my $input (@input) { my $packed = Data::MessagePack->pack($input); my $up = Data::MessagePack::Unpacker->new(); $up->execute($packed, 0); ok $up->is_finished, 'finished'; is_deeply($up->data, $input); } Data-MessagePack-0.49/META.yml0000644000175000017500000000131112624050607015331 0ustar syoheisyohei--- abstract: 'MessagePack serializing/deserializing' author: - 'Tokuhiro Matsuno' build_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.59 Test::More: 0.94 Test::Requires: 0 configure_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.59 ExtUtils::ParseXS: 3.18 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.16' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Data-MessagePack no_index: directory: - inc - t - xt requires: XSLoader: 0.02 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/msgpack/msgpack-perl version: '0.49' Data-MessagePack-0.49/Changes0000644000175000017500000001157412624050133015361 0ustar syoheisyohei0.49 2015-11-21 20:07:30+0900 - Fix undefined behavior issue of overflow(#23, #24, Thanks kazuho) 0.48 2013-09-01 15:42:51+0900 - Fix tests for bleadperl 0.47 - Support PUREPERL_ONLY build See the Lancaster Consensus: https://github.com/sjn/toolchain-site/blob/219db464af9b2f19b04fec05547ac10180a469f3/lancaster-consensus.md#specifying-pure-perl-builds 0.46 - fixed unpacking issue on big-endian system. https://github.com/msgpack/msgpack-perl/issues/4 0.45 - support tied hashes(rurban++) 0.44 - do not display deprecated warnings from Data::MessagePack::Unpacker. T::Xslate using it... 0.43 2012-06-26T02:00:57 - Data::MessagePack::Unpacker was deprecated. 0.42 2012-06-25 09:56:58 - fix failing to pack IV/NV with MAGIC (e.g. $$ in 5.16.0) 0.41 2012-03-28 01:09:44 - Revert the privous changed utf8() behavior 0.40 2012-03-28 00:37:28 - Fix $messagepack->utf8(1) behavior - Fix tests on NV == long double env 0.39 2011-12-05 00:08:58 - Resolve RT #72920 - packing float numbers fails on some cases, e.g. after e.g. $flaot > 0 0.38_02 2011-10-25 09:58:28 - More informative tests 0.38_01 2011-10-25 09:44:05 - Add tests to reveal problems in Data::Encoder 0.38 2011-10-10 16:17:03 - Add tests to unpacking double - the test was missing! 0.37 2011-10-10 16:08:18 - Resolve RT #71407: broken pack()/pack() for double on arm-oabi arch (the patch contributed by @shohex) 0.36 2011-08-21 14:41:51 - Fix a PP issue incompatible with XS impl - Fix docs 0.35_01 2011-08-19 15:27:00 - address issue/20 (cho45): Data::MessagePack did not finish correctly when was given devided packed data - address pull-req/82 (cho45): canonical mode like JSON.pm - added JSON.pm-compat interface - added utf8 mode to apply utf8::decode() when unpacking - deprecated $PreferInteger; use D::MP->new->prefer_integer - repository is now https://github.com/msgpack/msgpack-perl 0.34 - do not use the corrupt my_snprintf(%ll[du]) on win32(kazuho) 0.33 - fix tests (gfx) - optimize unpacking routines in Data::MessagePack::PP (gfx) 0.32 - add tests to detect Alpha problems reported via CPAN testers (gfx) 0.31 - update Module::Install::XSUtil for ccache support (gfx) - add version check at bootstrap in order to avoid load old .so (gfx) 0.30 - fix utf8 mode not to be reseted by $unpacker->reset method (gfx) 0.29 - add $unpacker->utf8 mode, decoding strings as UTF-8 (gfx) 0.28 - added more tests(gfx) - refactor the PP code(gfx) 0.27 - * 6d9a629 perl: modified trivial codes in PP::Unpacker(makamaka) - * ead8edc modified be unpack_(u)int64 in PP(makamaka) 0.26 - fixed a serious code typo in PP(makamaka) 0.25 (NO FEATURE CHANGES) - oops. I failed releng. 0.24 - Fixed a lot of streaming unpacking issues (tokuhirom, gfx) - Fixed unpacking issues for 64 bit integers on 32 bit perls (gfx) - Improved performance, esp. in unpacking (gfx) 0.23 (NO FEATURE CHANGES) - fixed english docs(hanekomu++) 0.22 - fixed issue on ithreads(broken from 0.21) 0.21 - doc enhancments - micro performance tuning. 0.20 - first production ready release with PP driver. 0.16_04 - no feature changes 0.16_02 - document enhancement(tokuhirom) - M::I::XSUtil 0.26 is broken. use 0.27. 0.16_01 - added PP version (used in cases PERL_DATA_MESSAGEPACK=pp or fail to load XS). - made Makefile.PL PP configurable. - test_pp in author's test - modified t/05_preferred_int.t for Win32 (makamaka) 0.16 - tests on 64bit machines with -Duselongdouble (reported by andk) 0.15 - better argument validation. (Dan Kogai) 0.14 - fixed segv on serializing cyclic reference (Dan Kogai) 0.13 - clearly specify requires_c99(), because msgpack C header requires C99. 0.12 - PERL_NO_GET_CONTEXT makes horrible dTHXs. remove it. 0.11 - oops(no feature changes) 0.10 - added more test cases. - fixed portability issue - (reviewed by gfx++) 0.09_01 - fixed memory leak issue(reported by Maxime Soulé) 0.09 - support NVTYPE=="long double" or IVTYPE=="long long" environment (thanks to Jun Kuriyama++) 0.08 - fixed PVNV issue... 0.07 - do not use switch (SvTYPE(val)). 0.06 - use SvNOK. 0.05 - change type detection for old perl 0.04 - check SvROK first(reported by yappo++) - PreferInteger: faster string to integer conversion; support negative value (frsyuki++) - make PreferInteger variable magical and remove get_sv from _msgpack_pack_sv (frsyuki++) 0.03 - performance tuning for too long string - fixed memory leaks in stream unpacker 0.02 - added $Data::MessagePack::PreferInteger (requested by yappo++) 0.01 - initial release to CPAN Data-MessagePack-0.49/xt/0000755000175000017500000000000012624050607014517 5ustar syoheisyoheiData-MessagePack-0.49/xt/leaks/0000755000175000017500000000000012624050607015616 5ustar syoheisyoheiData-MessagePack-0.49/xt/leaks/stream.t0000644000175000017500000000645312624045420017303 0ustar syoheisyoheiuse strict; use warnings; use Test::More; use Data::MessagePack; use Devel::Peek; plan skip_all => '$ENV{LEAK_TEST} is required' unless $ENV{LEAK_TEST}; my $input = [ { "ZCPGBENCH-1276933268" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "VDORBENCH-5637665303" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZVTHBENCH-7648578738" => { "1271859210" => [ "\x0a\x02\x04\x00\x00", "2600", "\x0a\x05\x04\x00\x00", "4600" ] }, "VMVTBENCH-5237337637" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZPLSBENCH-1823993880" => { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, "ZCPGBENCH-1995524375" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2330423245" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2963065090" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } } ]; $input = [(undef)x10]; my $r = Data::MessagePack->pack($input); my $n1 = trace(10); my $n2 = trace(10000); diag("$n1, $n2"); cmp_ok abs($n2-$n1), '<', 100; done_testing; sub trace { my $n = shift; my $before = memoryusage(); for ( 1 .. $n ) { my $unpacker = Data::MessagePack::Unpacker->new(); $unpacker->execute($r, 0); # ok $unpacker->is_finished if $i % 100 == 0; if ($unpacker->is_finished) { my $x = $unpacker->data; # is_deeply($x, $input) if $i % 100 == 0; } $unpacker->reset(); $unpacker->execute($r, 0); $unpacker->reset(); $unpacker->execute(substr($r, 0, 1), 0); $unpacker->execute(substr($r, 0, 2), 1); $unpacker->execute($r, 2); $unpacker->reset(); $r or die; } my $after = memoryusage(); diag("$n\t: $after - $before"); return $after - $before; } sub memoryusage { my $status = `cat /proc/$$/status`; my @lines = split( "\n", $status ); foreach my $line (@lines) { if ( $line =~ /^VmRSS:/ ) { $line =~ s/.*:\s*(\d+).*/$1/; return int($line); } } return -1; } __END__ [ { "ZCPGBENCH-1276933268" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "VDORBENCH-5637665303" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZVTHBENCH-7648578738" => { "1271859210" => [ "\x0a\x02\x04\x00\x00", "2600", "\x0a\x05\x04\x00\x00", "4600" ] }, "VMVTBENCH-5237337637" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZPLSBENCH-1823993880" => { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, "ZCPGBENCH-1995524375" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2330423245" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2963065090" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } } ] Data-MessagePack-0.49/xt/leaks/normal.t0000644000175000017500000000547112624045420017277 0ustar syoheisyoheiuse strict; use warnings; use Test::More; use Data::MessagePack; use Devel::Peek; plan skip_all => '$ENV{LEAK_TEST} is required' unless $ENV{LEAK_TEST}; my $input = [ { "ZCPGBENCH-1276933268" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "VDORBENCH-5637665303" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZVTHBENCH-7648578738" => { "1271859210" => [ "\x0a\x02\x04\x00\x00", "2600", "\x0a\x05\x04\x00\x00", "4600" ] }, "VMVTBENCH-5237337637" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZPLSBENCH-1823993880" => { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, "ZCPGBENCH-1995524375" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2330423245" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2963065090" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } } ]; my $r = Data::MessagePack->pack($input); my $n1 = trace(10); my $n2 = trace(10000); diag("$n1, $n2"); cmp_ok abs($n2-$n1), '<', 100; done_testing; sub trace { my $n = shift; my $before = memoryusage(); for ( 1 .. $n ) { my $x = Data::MessagePack->unpack($r); # is_deeply($x, $input); } my $after = memoryusage(); diag("$n\t: $after - $before"); return $after - $before; } sub memoryusage { my $status = `cat /proc/$$/status`; my @lines = split( "\n", $status ); foreach my $line (@lines) { if ( $line =~ /^VmRSS:/ ) { $line =~ s/.*:\s*(\d+).*/$1/; return int($line); } } return -1; } __END__ [ { "ZCPGBENCH-1276933268" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "VDORBENCH-5637665303" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZVTHBENCH-7648578738" => { "1271859210" => [ "\x0a\x02\x04\x00\x00", "2600", "\x0a\x05\x04\x00\x00", "4600" ] }, "VMVTBENCH-5237337637" => { "1271859210" => [ "\x00\x01\x00\x01\x00", 1 ] }, "ZPLSBENCH-1823993880" => { "1271859210" => [ "\x01\x07\x07\x03\x06", "10001" ] }, "ZCPGBENCH-1995524375" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2330423245" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "ZCPGBENCH-2963065090" => { "1271859210" => [ "\x14\x02\x07\x00\x00", 1 ] }, "MINT0" => { "1271859210" => [ "\x00\x01\x00\x01\x00", "D" ] } } ] Data-MessagePack-0.49/xt/99_pod.t0000644000175000017500000000020112624045420015775 0ustar syoheisyoheiuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Data-MessagePack-0.49/.gitmodules0000644000175000017500000000012212624045420016231 0ustar syoheisyohei[submodule "msgpack"] path = msgpack url = git://github.com/msgpack/msgpack.git Data-MessagePack-0.49/xs-src/0000755000175000017500000000000012624050607015303 5ustar syoheisyoheiData-MessagePack-0.49/xs-src/unpack.c0000644000175000017500000003071612624045420016734 0ustar syoheisyohei#define NEED_newRV_noinc #define NEED_sv_2pv_flags #include "xshelper.h" #define MY_CXT_KEY "Data::MessagePack::_unpack_guts" XS_VERSION typedef struct { SV* msgpack_true; SV* msgpack_false; } my_cxt_t; START_MY_CXT // context data for execute_template() typedef struct { bool finished; bool utf8; SV* buffer; } unpack_user; #define UNPACK_USER_INIT { false, false, NULL } #include "msgpack/unpack_define.h" #define msgpack_unpack_struct(name) \ struct template ## name #define msgpack_unpack_func(ret, name) \ STATIC_INLINE ret template ## name #define msgpack_unpack_callback(name) \ template_callback ## name #define msgpack_unpack_object SV* #define msgpack_unpack_user unpack_user void init_Data__MessagePack_unpack(pTHX_ bool const cloning) { // booleans are load on demand (lazy load). if(!cloning) { MY_CXT_INIT; PERL_UNUSED_VAR(MY_CXT); } else { MY_CXT_CLONE; } dMY_CXT; MY_CXT.msgpack_true = NULL; MY_CXT.msgpack_false = NULL; } /* ---------------------------------------------------------------------- */ /* utility functions */ static SV* load_bool(pTHX_ const char* const name) { CV* const cv = get_cv(name, GV_ADD); dSP; ENTER; SAVETMPS; PUSHMARK(SP); call_sv((SV*)cv, G_SCALAR); SPAGAIN; SV* const sv = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; assert(sv); assert(sv_isobject(sv)); if(!SvOK(sv)) { croak("Oops: Failed to load %"SVf, name); } return sv; } static SV* get_bool(bool const value) { dTHX; dMY_CXT; if(value) { if(!MY_CXT.msgpack_true) { MY_CXT.msgpack_true = load_bool(aTHX_ "Data::MessagePack::true"); } return newSVsv(MY_CXT.msgpack_true); } else { if(!MY_CXT.msgpack_false) { MY_CXT.msgpack_false = load_bool(aTHX_ "Data::MessagePack::false"); } return newSVsv(MY_CXT.msgpack_false); } } /* ---------------------------------------------------------------------- */ struct template_context; typedef struct template_context msgpack_unpack_t; static void template_init(msgpack_unpack_t* u); static SV* template_data(msgpack_unpack_t* u); static int template_execute(msgpack_unpack_t* u PERL_UNUSED_DECL, const char* data, size_t len, size_t* off); STATIC_INLINE SV* template_callback_root(unpack_user* u PERL_UNUSED_DECL) { return NULL; } #if IVSIZE == 4 STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) { dTHX; *o = newSVuv(d); return 0; } STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) { dTHX; *o = newSViv(d); return 0; } /* workaround win32 problems (my_snprintf(%llu) returns incorrect values ) */ static char* str_from_uint64(char* buf_end, uint64_t v) { char *p = buf_end; *--p = '\0'; do { *--p = '0' + v % 10; } while ((v /= 10) != 0); return p; } static const char* str_from_int64(char* buf_end, int64_t const v) { bool const minus = v < 0; char* p = str_from_uint64(buf_end, minus ? -v : v); if (minus) *--p = '-'; return p; } static int template_callback_uint64(unpack_user* u PERL_UNUSED_DECL, uint64_t const d, SV** o) { dTHX; char tbuf[64]; const char* const s = str_from_uint64(tbuf + sizeof(tbuf), d); *o = newSVpvn(s, tbuf + sizeof(tbuf) - 1 - s); return 0; } static int template_callback_int64(unpack_user* u PERL_UNUSED_DECL, int64_t const d, SV** o) { dTHX; char tbuf[64]; const char* const s = str_from_int64(tbuf + sizeof(tbuf), d); *o = newSVpvn(s, tbuf + sizeof(tbuf) - 1 - s); return 0; } #else /* IVSIZE == 8 */ STATIC_INLINE int template_callback_UV(unpack_user* u PERL_UNUSED_DECL, UV const d, SV** o) { dTHX; *o = newSVuv(d); return 0; } #define template_callback_uint64 template_callback_UV STATIC_INLINE int template_callback_IV(unpack_user* u PERL_UNUSED_DECL, IV const d, SV** o) { dTHX; *o = newSViv(d); return 0; } #define template_callback_int64 template_callback_IV #endif /* IVSIZE */ #define template_callback_uint8 template_callback_UV #define template_callback_uint16 template_callback_UV #define template_callback_uint32 template_callback_UV #define template_callback_int8 template_callback_IV #define template_callback_int16 template_callback_IV #define template_callback_int32 template_callback_IV #define template_callback_float template_callback_double STATIC_INLINE int template_callback_double(unpack_user* u PERL_UNUSED_DECL, double d, SV** o) { dTHX; *o = newSVnv(d); return 0; } /* &PL_sv_undef is not so good. see http://gist.github.com/387743 */ STATIC_INLINE int template_callback_nil(unpack_user* u PERL_UNUSED_DECL, SV** o) { dTHX; *o = newSV(0); return 0; } STATIC_INLINE int template_callback_true(unpack_user* u PERL_UNUSED_DECL, SV** o) { *o = get_bool(true); return 0; } STATIC_INLINE int template_callback_false(unpack_user* u PERL_UNUSED_DECL, SV** o) { *o = get_bool(false); return 0; } STATIC_INLINE int template_callback_array(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) { dTHX; AV* const a = newAV(); *o = newRV_noinc((SV*)a); av_extend(a, n + 1); return 0; } STATIC_INLINE int template_callback_array_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* o) { dTHX; AV* const a = (AV*)SvRV(*c); assert(SvTYPE(a) == SVt_PVAV); (void)av_store(a, AvFILLp(a) + 1, o); // the same as av_push(a, o) return 0; } STATIC_INLINE int template_callback_map(unpack_user* u PERL_UNUSED_DECL, unsigned int n, SV** o) { dTHX; HV* const h = newHV(); hv_ksplit(h, n); *o = newRV_noinc((SV*)h); return 0; } STATIC_INLINE int template_callback_map_item(unpack_user* u PERL_UNUSED_DECL, SV** c, SV* k, SV* v) { dTHX; HV* const h = (HV*)SvRV(*c); assert(SvTYPE(h) == SVt_PVHV); (void)hv_store_ent(h, k, v, 0); SvREFCNT_dec(k); return 0; } STATIC_INLINE int template_callback_raw(unpack_user* u PERL_UNUSED_DECL, const char* b PERL_UNUSED_DECL, const char* p, unsigned int l, SV** o) { dTHX; /* newSVpvn(p, l) returns an undef if p == NULL */ *o = ((l==0) ? newSVpvs("") : newSVpvn(p, l)); if(u->utf8) { sv_utf8_decode(*o); } return 0; } #include "msgpack/unpack_template.h" #define UNPACKER(from, name) \ msgpack_unpack_t *name; \ { \ SV* const obj = from; \ if(!(SvROK(obj) && SvIOK(SvRV(obj)))) { \ Perl_croak(aTHX_ "Invalid unpacker instance for " #name); \ } \ name = INT2PTR(msgpack_unpack_t*, SvIVX(SvRV((obj)))); \ if(name == NULL) { \ Perl_croak(aTHX_ "NULL found for " # name " when shouldn't be"); \ } \ } XS(xs_unpack) { dXSARGS; SV* const self = ST(0); SV* const data = ST(1); size_t limit; unpack_user u = UNPACK_USER_INIT; // setup configuration if(SvROK(self) && SvTYPE(SvRV(self)) == SVt_PVHV) { HV* const hv = (HV*)SvRV(self); SV** svp; svp = hv_fetchs(hv, "utf8", FALSE); if(svp) { u.utf8 = SvTRUE(*svp) ? true : false; } } if (items == 2) { limit = sv_len(data); } else if(items == 3) { limit = SvUVx(ST(2)); } else { Perl_croak(aTHX_ "Usage: Data::MessagePack->unpack('data' [, $limit])"); } STRLEN dlen; const char* const dptr = SvPV_const(data, dlen); msgpack_unpack_t mp; template_init(&mp); mp.user = u; size_t from = 0; int const ret = template_execute(&mp, dptr, (size_t)dlen, &from); SV* const obj = template_data(&mp); sv_2mortal(obj); if(ret < 0) { Perl_croak(aTHX_ "Data::MessagePack->unpack: parse error"); } else if(ret == 0) { Perl_croak(aTHX_ "Data::MessagePack->unpack: insufficient bytes"); } else { if(from < dlen) { Perl_croak(aTHX_ "Data::MessagePack->unpack: extra bytes"); } } ST(0) = obj; XSRETURN(1); } /* ------------------------------ stream -- */ /* http://twitter.com/frsyuki/status/13249304748 */ XS(xs_unpacker_new) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: Data::MessagePack::Unpacker->new()"); } SV* const self = sv_newmortal(); msgpack_unpack_t *mp; Newxz(mp, 1, msgpack_unpack_t); template_init(mp); unpack_user const u = UNPACK_USER_INIT; mp->user = u; mp->user.buffer = newSV(80); sv_setpvs(mp->user.buffer, ""); sv_setref_pv(self, "Data::MessagePack::Unpacker", mp); ST(0) = self; XSRETURN(1); } XS(xs_unpacker_utf8) { dXSARGS; if (!(items == 1 || items == 2)) { Perl_croak(aTHX_ "Usage: $unpacker->utf8([$bool)"); } UNPACKER(ST(0), mp); mp->user.utf8 = (items == 1 || sv_true(ST(1))) ? true : false; XSRETURN(1); // returns $self } XS(xs_unpacker_get_utf8) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: $unpacker->get_utf8()"); } UNPACKER(ST(0), mp); ST(0) = boolSV(mp->user.utf8); XSRETURN(1); } STATIC_INLINE size_t _execute_impl(SV* const self, SV* const data, UV const offset, UV const limit) { dTHX; if(offset >= limit) { Perl_croak(aTHX_ "offset (%"UVuf") is bigger than data buffer size (%"UVuf")", offset, limit); } UNPACKER(self, mp); size_t from = offset; const char* dptr = SvPV_nolen_const(data); STRLEN dlen = limit; if(SvCUR(mp->user.buffer) != 0) { sv_catpvn(mp->user.buffer, dptr, dlen); dptr = SvPV_const(mp->user.buffer, dlen); from = 0; } int const ret = template_execute(mp, dptr, dlen, &from); // ret < 0 : error // ret == 0 : insufficient // ret > 0 : success if(ret < 0) { Perl_croak(aTHX_ "Data::MessagePack::Unpacker: parse error while executing"); } mp->user.finished = (ret > 0) ? true : false; if(!mp->user.finished) { template_init(mp); // reset the state sv_setpvn(mp->user.buffer, dptr, dlen); from = 0; } else { sv_setpvs(mp->user.buffer, ""); } //warn(">> (%d) dlen=%d, from=%d, rest=%d", // (int)ret, (int)dlen, (int)from, dlen - from); return from; } XS(xs_unpacker_execute) { dXSARGS; SV* const self = ST(0); SV* const data = ST(1); UV offset; if (items == 2) { offset = 0; } else if (items == 3) { offset = SvUVx(ST(2)); } else { Perl_croak(aTHX_ "Usage: $unpacker->execute(data, offset = 0)"); } dXSTARG; sv_setuv(TARG, _execute_impl(self, data, offset, sv_len(data))); ST(0) = TARG; XSRETURN(1); } XS(xs_unpacker_execute_limit) { dXSARGS; if (items != 4) { Perl_croak(aTHX_ "Usage: $unpacker->execute_limit(data, offset, limit)"); } SV* const self = ST(0); SV* const data = ST(1); UV const offset = SvUVx(ST(2)); UV const limit = SvUVx(ST(3)); dXSTARG; sv_setuv(TARG, _execute_impl(self, data, offset, limit)); ST(0) = TARG; XSRETURN(1); } XS(xs_unpacker_is_finished) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: $unpacker->is_finished()"); } UNPACKER(ST(0), mp); ST(0) = boolSV(mp->user.finished); XSRETURN(1); } XS(xs_unpacker_data) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: $unpacker->data()"); } UNPACKER(ST(0), mp); ST(0) = template_data(mp); XSRETURN(1); } XS(xs_unpacker_reset) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: $unpacker->reset()"); } UNPACKER(ST(0), mp); SV* const data = template_data(mp); SvREFCNT_dec(data); template_init(mp); sv_setpvs(mp->user.buffer, ""); XSRETURN(0); } XS(xs_unpacker_destroy) { dXSARGS; if (items != 1) { Perl_croak(aTHX_ "Usage: $unpacker->DESTROY()"); } UNPACKER(ST(0), mp); SV* const data = template_data(mp); SvREFCNT_dec(data); SvREFCNT_dec(mp->user.buffer); Safefree(mp); XSRETURN(0); } Data-MessagePack-0.49/xs-src/pack.c0000644000175000017500000002236512624045420016372 0ustar syoheisyohei/* * code is written by tokuhirom. * buffer alocation technique is taken from JSON::XS. thanks to mlehmann. */ #include "xshelper.h" #include "msgpack/pack_define.h" #define msgpack_pack_inline_func(name) \ static inline void msgpack_pack ## name #define msgpack_pack_inline_func_cint(name) \ static inline void msgpack_pack ## name // serialization context typedef struct { char *cur; /* SvPVX (sv) + current output position */ const char *end; /* SvEND (sv) */ SV *sv; /* result scalar */ bool prefer_int; bool canonical; } enc_t; STATIC_INLINE void dmp_append_buf(enc_t* const enc, const void* const buf, STRLEN const len) { if (enc->cur + len >= enc->end) { dTHX; STRLEN const cur = enc->cur - SvPVX_const(enc->sv); sv_grow (enc->sv, cur + (len < (cur >> 2) ? cur >> 2 : len) + 1); enc->cur = SvPVX_mutable(enc->sv) + cur; enc->end = SvPVX_const(enc->sv) + SvLEN (enc->sv) - 1; } memcpy(enc->cur, buf, len); enc->cur += len; } #define msgpack_pack_user enc_t* #define msgpack_pack_append_buffer(enc, buf, len) \ dmp_append_buf(enc, buf, len) #include "msgpack/pack_template.h" #define INIT_SIZE 32 /* initial scalar size to be allocated */ #if IVSIZE == 8 # define PACK_IV msgpack_pack_int64 # define PACK_UV msgpack_pack_uint64 #elif IVSIZE == 4 # define PACK_IV msgpack_pack_int32 # define PACK_UV msgpack_pack_uint32 #elif IVSIZE == 2 # define PACK_IV msgpack_pack_int16 # define PACK_UV msgpack_pack_uint16 #else # error "msgpack only supports IVSIZE = 8,4,2 environment." #endif #define ERR_NESTING_EXCEEDED "perl structure exceeds maximum nesting level (max_depth set too low?)" #define DMP_PREF_INT "PreferInteger" /* interpreter global variables */ #define MY_CXT_KEY "Data::MessagePack::_pack_guts" XS_VERSION typedef struct { bool prefer_int; bool canonical; } my_cxt_t; START_MY_CXT static int dmp_config_set(pTHX_ SV* sv, MAGIC* mg) { dMY_CXT; assert(mg->mg_ptr); if(strEQ(mg->mg_ptr, DMP_PREF_INT)) { MY_CXT.prefer_int = SvTRUE(sv) ? true : false; } else { assert(0); } return 0; } MGVTBL dmp_config_vtbl = { NULL, dmp_config_set, NULL, NULL, NULL, NULL, NULL, #ifdef MGf_LOCAL NULL, #endif }; void init_Data__MessagePack_pack(pTHX_ bool const cloning) { if(!cloning) { MY_CXT_INIT; MY_CXT.prefer_int = false; MY_CXT.canonical = false; } else { MY_CXT_CLONE; } SV* var = get_sv("Data::MessagePack::" DMP_PREF_INT, GV_ADDMULTI); sv_magicext(var, NULL, PERL_MAGIC_ext, &dmp_config_vtbl, DMP_PREF_INT, 0); SvSETMAGIC(var); } STATIC_INLINE int try_int(enc_t* enc, const char *p, size_t len) { int negative = 0; const char* pe = p + len; uint64_t num = 0; if (len == 0) { return 0; } if (*p == '-') { /* length(-0x80000000) == 11 */ if (len <= 1 || len > 11) { return 0; } negative = 1; ++p; } else { /* length(0xFFFFFFFF) == 10 */ if (len > 10) { return 0; } } #if '9'=='8'+1 && '8'=='7'+1 && '7'=='6'+1 && '6'=='5'+1 && '5'=='4'+1 \ && '4'=='3'+1 && '3'=='2'+1 && '2'=='1'+1 && '1'=='0'+1 do { unsigned int c = ((int)*(p++)) - '0'; if (c > 9) { return 0; } num = num * 10 + c; } while(p < pe); #else do { switch (*(p++)) { case '0': num = num * 10 + 0; break; case '1': num = num * 10 + 1; break; case '2': num = num * 10 + 2; break; case '3': num = num * 10 + 3; break; case '4': num = num * 10 + 4; break; case '5': num = num * 10 + 5; break; case '6': num = num * 10 + 6; break; case '7': num = num * 10 + 7; break; case '8': num = num * 10 + 8; break; case '9': num = num * 10 + 9; break; default: return 0; } } while(p < pe); #endif if (negative) { if (num > 0x80000000) { return 0; } msgpack_pack_int32(enc, ((int32_t)-num)); } else { if (num > 0xFFFFFFFF) { return 0; } msgpack_pack_uint32(enc, (uint32_t)num); } return 1; } STATIC_INLINE void _msgpack_pack_rv(pTHX_ enc_t *enc, SV* sv, int depth); STATIC_INLINE void _msgpack_pack_sv(pTHX_ enc_t* const enc, SV* const sv, int const depth) { assert(sv); if (UNLIKELY(depth <= 0)) Perl_croak(aTHX_ ERR_NESTING_EXCEEDED); SvGETMAGIC(sv); if (SvPOKp(sv)) { STRLEN const len = SvCUR(sv); const char* const pv = SvPVX_const(sv); if (enc->prefer_int && try_int(enc, pv, len)) { return; } else { msgpack_pack_raw(enc, len); msgpack_pack_raw_body(enc, pv, len); } } else if (SvNOKp(sv)) { msgpack_pack_double(enc, (double)SvNVX(sv)); } else if (SvIOKp(sv)) { if(SvUOK(sv)) { PACK_UV(enc, SvUVX(sv)); } else { PACK_IV(enc, SvIVX(sv)); } } else if (SvROK(sv)) { _msgpack_pack_rv(aTHX_ enc, SvRV(sv), depth-1); } else if (!SvOK(sv)) { msgpack_pack_nil(enc); } else if (isGV(sv)) { Perl_croak(aTHX_ "msgpack cannot pack the GV\n"); } else { sv_dump(sv); Perl_croak(aTHX_ "msgpack for perl doesn't supported this type: %d\n", SvTYPE(sv)); } } STATIC_INLINE void _msgpack_pack_he(pTHX_ enc_t* enc, HV* hv, HE* he, int depth) { _msgpack_pack_sv(aTHX_ enc, hv_iterkeysv(he), depth); _msgpack_pack_sv(aTHX_ enc, hv_iterval(hv, he), depth); } STATIC_INLINE void _msgpack_pack_rv(pTHX_ enc_t *enc, SV* sv, int depth) { svtype svt; assert(sv); SvGETMAGIC(sv); svt = SvTYPE(sv); if (SvOBJECT (sv)) { HV *stash = gv_stashpv ("Data::MessagePack::Boolean", 1); // TODO: cache? if (SvSTASH (sv) == stash) { if (SvIV(sv)) { msgpack_pack_true(enc); } else { msgpack_pack_false(enc); } } else { croak ("encountered object '%s', Data::MessagePack doesn't allow the object", SvPV_nolen(sv_2mortal(newRV_inc(sv)))); } } else if (svt == SVt_PVHV) { HV* hval = (HV*)sv; int count = hv_iterinit(hval); HE* he; if (SvTIED_mg(sv,PERL_MAGIC_tied)) { count = 0; while (hv_iternext (hval)) ++count; hv_iterinit (hval); } msgpack_pack_map(enc, count); if (enc->canonical) { AV* const keys = newAV(); sv_2mortal((SV*)keys); av_extend(keys, count); while ((he = hv_iternext(hval))) { av_push(keys, SvREFCNT_inc(hv_iterkeysv(he))); } int const len = av_len(keys) + 1; sortsv(AvARRAY(keys), len, Perl_sv_cmp); int i; for (i=0; ipack($dat [,$max_depth])"); } SV* self = ST(0); SV* val = ST(1); int depth = 512; if (items >= 3) depth = SvIVx(ST(2)); enc_t enc; enc.sv = sv_2mortal(newSV(INIT_SIZE)); enc.cur = SvPVX(enc.sv); enc.end = SvEND(enc.sv); SvPOK_only(enc.sv); // setup configuration dMY_CXT; enc.prefer_int = MY_CXT.prefer_int; // back compat if(SvROK(self) && SvTYPE(SvRV(self)) == SVt_PVHV) { HV* const hv = (HV*)SvRV(self); SV** svp; svp = hv_fetchs(hv, "prefer_integer", FALSE); if(svp) { enc.prefer_int = SvTRUE(*svp) ? true : false; } svp = hv_fetchs(hv, "canonical", FALSE); if(svp) { enc.canonical = SvTRUE(*svp) ? true : false; } } _msgpack_pack_sv(aTHX_ &enc, val, depth); SvCUR_set(enc.sv, enc.cur - SvPVX (enc.sv)); *SvEND (enc.sv) = 0; /* many xs functions expect a trailing 0 for text strings */ ST(0) = enc.sv; XSRETURN(1); } Data-MessagePack-0.49/xs-src/MessagePack.xs0000644000175000017500000000326612624045420020046 0ustar syoheisyohei#include "xshelper.h" #ifndef __cplusplus #include #endif XS(xs_pack); XS(xs_unpack); XS(xs_unpacker_new); XS(xs_unpacker_utf8); XS(xs_unpacker_get_utf8); XS(xs_unpacker_execute); XS(xs_unpacker_execute_limit); XS(xs_unpacker_is_finished); XS(xs_unpacker_data); XS(xs_unpacker_reset); XS(xs_unpacker_destroy); void init_Data__MessagePack_pack(pTHX_ bool const cloning); void init_Data__MessagePack_unpack(pTHX_ bool const cloning); MODULE = Data::MessagePack PACKAGE = Data::MessagePack BOOT: { init_Data__MessagePack_pack(aTHX_ false); init_Data__MessagePack_unpack(aTHX_ false); newXS("Data::MessagePack::pack", xs_pack, __FILE__); newXS("Data::MessagePack::unpack", xs_unpack, __FILE__); newXS("Data::MessagePack::Unpacker::new", xs_unpacker_new, __FILE__); newXS("Data::MessagePack::Unpacker::utf8", xs_unpacker_utf8, __FILE__); newXS("Data::MessagePack::Unpacker::get_utf8", xs_unpacker_get_utf8, __FILE__); newXS("Data::MessagePack::Unpacker::execute", xs_unpacker_execute, __FILE__); newXS("Data::MessagePack::Unpacker::execute_limit", xs_unpacker_execute_limit, __FILE__); newXS("Data::MessagePack::Unpacker::is_finished", xs_unpacker_is_finished, __FILE__); newXS("Data::MessagePack::Unpacker::data", xs_unpacker_data, __FILE__); newXS("Data::MessagePack::Unpacker::reset", xs_unpacker_reset, __FILE__); newXS("Data::MessagePack::Unpacker::DESTROY", xs_unpacker_destroy, __FILE__); } #ifdef USE_ITHREADS void CLONE(...) CODE: { PERL_UNUSED_VAR(items); init_Data__MessagePack_pack(aTHX_ true); init_Data__MessagePack_unpack(aTHX_ true); } #endif // USE_ITHREADS Data-MessagePack-0.49/MANIFEST0000644000175000017500000000255612624050457015230 0ustar syoheisyohei.gitmodules benchmark/data.pl benchmark/deserialize.pl benchmark/serialize.pl benchmark/size.pl Changes inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Module/Install/XSUtil.pm include/msgpack/pack_define.h include/msgpack/pack_template.h include/msgpack/sysdep.h include/msgpack/unpack_define.h include/msgpack/unpack_template.h lib/Data/MessagePack.pm lib/Data/MessagePack/Boolean.pm lib/Data/MessagePack/PP.pm lib/Data/MessagePack/Unpacker.pod LICENSE Makefile.PL MANIFEST This list of files META.yml README t/00_compile.t t/01_pack.t t/02_unpack.t t/03_stream_unpack.t t/04_invert.t t/05_preferred_int.t t/06_stream_unpack2.t t/07_break.t t/08_cycle.t t/09_stddata.t t/10_splitted_bytes.t t/11_stream_unpack3.t t/12_stream_unpack4.t t/13_booleans.t t/14_invalid_data.t t/15_utf8.t t/16_unpacker_for_larges.t t/17_canonical.t t/18_new_interface.t t/19_utf8_property.t t/20_de.t t/21_dirty_float.t t/22_pid_pack_unpack.t t/23-empty-key.t t/24_tied.t t/40_threads.t t/50_leaktrace.t t/data.pl t/std/cases.json t/std/cases.mpac t/std/cases_compact.mpac t/Util.pm xs-src/MessagePack.xs xs-src/pack.c xs-src/unpack.c xshelper.h xt/99_pod.t xt/leaks/normal.t xt/leaks/stream.t Data-MessagePack-0.49/Makefile.PL0000644000175000017500000000703212624045420016035 0ustar syoheisyohei# Usage: Makefile.PL --pp # disable XS # Makefile.PL -g # add -g to the compiler and disable optimization flags use inc::Module::Install; use Module::Install::XSUtil 0.44; use Module::Install::AuthorTests; name 'Data-MessagePack'; all_from 'lib/Data/MessagePack.pm'; test_requires('Test::More' => 0.94); # done_testing test_requires('Test::Requires'); tests 't/*.t'; recursive_author_tests('xt'); if ($Module::Install::AUTHOR) { init_msgpack(); } my $use_xs = 0; if ( $] >= 5.008005 and want_xs() ) { my $has_c99 = c99_available(); # msgpack C library requires C99. if ( $has_c99 ) { requires_c99(); use_xshelper(); cc_warnings; cc_include_paths('include'); cc_src_paths('xs-src'); postamble (qq{ xs-src/pack.o : xshelper.h include/msgpack/pack_define.h include/msgpack/pack_template.h include/msgpack/sysdep.h xs-src/unpack.o : xshelper.h include/msgpack/unpack_define.h include/msgpack/unpack_template.h include/msgpack/sysdep.h }); if($Module::Install::AUTHOR) { postamble qq{test :: test_pp\n\n}; } $use_xs = 1; } else { print < 1.89; # old versions of BigInt were broken } test_with_env( test_pp => PERL_DATA_MESSAGEPACK => 'pp' ); repository('http://github.com/msgpack/msgpack-perl'); clean_files qw{ *.stackdump *.gcov *.gcda *.gcno *.out nytprof cover_db }; WriteAll; # copied from Makefile.PL in Text::Xslate. sub test_with_env { my($name, %env) = @_; my $dir = '.testenv'; if(not -e $dir) { mkdir $dir or die "Cannot mkdir '.testenv': $!"; } clean_files($dir); { open my $out, '>', "$dir/$name.pl" or die "Cannot open '$dir/$name.pl' for writing: $!"; print $out "# This file sets the env for 'make $name', \n"; print $out "# generated by $0 at ", scalar(localtime), ".\n"; print $out "# DO NOT EDIT THIS FILE DIRECTLY.\n"; print $out "\n"; while(my($name, $value) = each %env) { printf $out '$ENV{q{%s}} = q{%s};'."\n", $name, $value; } } # repeat testing for pure Perl mode # see also ExtUtils::MM_Any::test_via_harness() my $t = q{$(FULLPERLRUN) -MExtUtils::Command::MM -e} .q{ "do q[%s]; test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')"} .q{ $(TEST_FILES)}; postamble qq{$name :: pure_all\n} . qq{\t} . q{$(NOECHO) $(ECHO) TESTING: } . $name . qq{\n} . qq{\t} . sprintf($t, "$dir/$name.pl") . qq{\n\n} . qq{testall :: $name\n\n}; return; } sub init_msgpack { print "AuthorMode: copy modules\n"; if(not -d 'include') { system 'git', 'submodule', 'init'; system 'git', 'submodule', 'update'; } else { system 'git', 'submodule', 'sync'; } require File::Path; require File::Copy; File::Path::rmtree([qw(include t/std)]); File::Path::mkpath([qw(include/msgpack t/std)]); for my $src () { print "AuthorMode: copy $src to include/msgpack\n"; File::Copy::copy($src, 'include/msgpack') or die "copy failed: $!"; } for my $src() { print "AuthorMode: copy $src to t/std/\n"; File::Copy::copy($src, 't/std') or die "copy failed: $!"; } } Data-MessagePack-0.49/LICENSE0000644000175000017500000004372212624045420015076 0ustar syoheisyoheiThis software is copyright (c) 2015- by Tokuhiro Matsuno. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015- by Nikolay Mishin < mi@ya.ru >. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015- by Nikolay Mishin < mi@ya.ru >. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End