"{ Package: 'stx:goodies/xtreams/transforms' }"

"{ NameSpace: Xtreams }"

Object subclass:#MessagePackMarshaler
	instanceVariableNames:'unmarshaling marshaling analysing'
	classVariableNames:''
	poolDictionaries:'XtreamsPool'
	category:'Xtreams-Transforms'
!

MessagePackMarshaler comment:'MessagePackMarshaler defines the binary format of the MessagePack protocol ( http://wiki.msgpack.org/display/MSGPACK/Format+specification ), which is a binary JSON. It can marshal simple objects, but not whole classes, just like JSON. It is considered to be a very fast marshaler because of its lightweight protocol. It cannot handle circular references.

Instance Variables
	analysing	<Object>	analysing operations
	marshaling	<Dictionary>	marshaling operations
	unmarshaling	<(Array of: (BlockClosure))>	unmarshaling operations



'
!


!MessagePackMarshaler class methodsFor:'instance creation'!

new
	^super new initialize
! !

!MessagePackMarshaler class methodsFor:'constants - containers'!

array16
	^16rDC
!

array32
	^16rDD
!

map16
	^16rDE
!

map32
	^16rDF
!

raw16
	^16rDA
!

raw32
	^16rDB
! !

!MessagePackMarshaler class methodsFor:'constants - numbers'!

double
	^16rCB
!

float
	^16rCA
!

int16
	^16rD1
!

int32
	^16rD2
!

int64
	^16rD3
!

int8
	^16rD0
!

uint16
	^16rCD
!

uint32
	^16rCE
!

uint64
	^16rCF
!

uint8
	^16rCC
! !

!MessagePackMarshaler class methodsFor:'constants - singletons'!

false
	^16rC2
!

nil
	^16rC0
!

true
	^16rC3
! !

!MessagePackMarshaler methodsFor:'api'!

analyse: reading
	| type |
	type := reading uint8 get.
	type <= 16rBF ifTrue: [
		| fixMapOrArray |
		type <= 16r7F ifTrue: [^reading log: 'positive fixnum' do: [type]].
		fixMapOrArray := type bitShift: -4.
		fixMapOrArray = 2r1001 ifTrue: [^reading log: 'fix array' do: [(1 to: (type bitAnd: 2r00001111)) collect: [:i | self analyse: reading]]].
		fixMapOrArray = 2r1000 ifTrue: [
			^reading log: 'fix map' do: [
				| map |
				map := Dictionary new.
				(type bitAnd: 2r00001111) timesRepeat: [
					map at: (self analyse: reading) put: (self analyse: reading)].
				map]].
		^reading log: 'fix raw' do: [reading uint8 read: (type bitAnd: 2r00011111)]].
	(type bitShift: -5) = 2r111 ifTrue: [^reading log: 'negative fixnum' do: [-32 + (type bitAnd: 2r00011111)]].
	^reading log: (type printStringRadix: 16) do: [(analysing at: type) value: reading]
!

marshal: writing object: object
	(marshaling at: object class ifAbsent: [self error: 'Unmarshalable class with the MessagePack protocol']) value: writing value: object
!

unmarshal: reading
	| type |
	type := reading uint8 get.
	type <= 16rBF ifTrue: [
		| fixMapOrArray |
		type <= 16r7F ifTrue: [^type].
		fixMapOrArray := type bitShift: -4.
		fixMapOrArray = 2r1001 ifTrue: [^(1 to: (type bitAnd: 2r00001111)) collect: [:i | self unmarshal: reading]].
		fixMapOrArray = 2r1000 ifTrue: [
			| map |
			map := Dictionary new.
			(type bitAnd: 2r00001111) timesRepeat: [
				map at: (self unmarshal: reading) put: (self unmarshal: reading)].
			^map].
		^reading uint8 read: (type bitAnd: 2r00011111)].
	(type bitShift: -5) = 2r111 ifTrue: [^-32 + (type bitAnd: 2r00011111)].
	^(unmarshaling at: type) value: reading
! !

!MessagePackMarshaler methodsFor:'configuration'!

configureAnalyse: reading
	"This protocol has fixed endianness built in"
	^true
!

configureMarshal: writing
	"This protocol has fixed endianness built in"
	^true
!

configureUnmarshal: reading
	"This protocol has fixed endianness built in"
	^true
! !

!MessagePackMarshaler methodsFor:'initialize-release'!

initialize
	self initializeMarshaling.
	self initializeUnmarshaling.
	self initializeAnalysing.
!

initializeAnalysing
	(analysing := unmarshaling copy)
		at: self class array16 put: [:reading | reading log: 'array16' do: [(1 to: reading uint16 get) collect: [:i | self analyse: reading]]];
		at: self class array32 put: [:reading | reading log: 'array32' do: [(1 to: reading uint32 get) collect: [:i | self analyse: reading]]];
		at: self class map16 put: [:reading |
			reading log: 'map16' do: [
				| map |
				map := Dictionary new.
				reading uint16 get timesRepeat: [
					map at: (self analyse: reading) put: (self analyse:reading)].
				map]];
		at: self class map32 put: [:reading |
			reading log: 'map32' do: [
				| map |
				map := Dictionary new.
				reading uint16 get timesRepeat: [
					map at: (self analyse: reading) put: (self analyse: reading)].
				map]];
		yourself
!

initializeMarshaling
	(marshaling := Dictionary new)
		"singletons"
		at: UndefinedObject put: [:writing :object | writing uint8 put: self class nil];
		at: True put: [:writing :object | writing uint8 put: self class true];
		at: False put: [:writing :object | writing uint8 put: self class false];

		"numbers"
		at: Float put: [:writing :object | writing uint8 put: self class float. writing float put: object];
		at: Double put: [:writing :object | writing uint8 put: self class double. writing double put: object];
		at: SmallDouble put: [:writing :object | writing uint8 put: self class double. writing double put: object];
		yourself.

	Integer allSubclassesDo: [:each |
		marshaling at: each put: [:writing :object | self write: writing integer: object]].

	SequenceableCollection allSubclassesDo: [:each |
		marshaling at: each put: [:writing :object | self write: writing array: object]].
	(KeyedCollection withAllSubclasses, Dictionary withAllSubclasses) do: [:each |
		marshaling at: each put: [:writing :object | self write: writing map: object]].
	(CharacterArray withAllSubclasses, IntegerArray withAllSubclasses) do: [:each |
		marshaling at: each put: [:writing :object | self error: each name, ' are not supported by the MessagePack protocol']].
	marshaling at: ByteArray put: [:writing :object | self write: writing raw: object]
!

initializeUnmarshaling
	(unmarshaling := Array new: 255 withAll: [:reading | self error: 'unknown type'])
		"singletons"
		at: self class nil put: [:reading | nil];
		at: self class true put: [:reading | true];
		at: self class false put: [:reading | false];

		"numbers"
		at: self class uint8 put: [:reading | reading uint8 get];
		at: self class uint16 put: [:reading | reading uint16 get];
		at: self class uint32 put: [:reading | reading uint32 get];
		at: self class uint64 put: [:reading | reading uint64 get];
		at: self class int8 put: [:reading | reading int8 get];
		at: self class int16 put: [:reading | reading int16 get];
		at: self class int32 put: [:reading | reading int32 get];
		at: self class int64 put: [:reading | reading int64 get];
		at: self class float put: [:reading | reading float get];
		at: self class double put: [:reading | reading double get];

		"containers"
		at: self class raw16 put: [:reading | reading uint8 read: reading uint16 get];
		at: self class raw32 put: [:reading | reading uint8 read: reading uint32 get];
		at: self class array16 put: [:reading | (1 to: reading uint16 get) collect: [:i | self unmarshal: reading]];
		at: self class array32 put: [:reading | (1 to: reading uint32 get) collect: [:i | self unmarshal: reading]];
		at: self class map16 put: [:reading |
			| map |
			map := Dictionary new.
			reading uint16 get timesRepeat: [
				map at: (self unmarshal: reading) put: (self unmarshal: reading)].
			map];
		at: self class map32 put: [:reading |
			| map |
			map := Dictionary new.
			reading uint32 get timesRepeat: [
				map at: (self unmarshal: reading) put: (self unmarshal: reading)].
			map];
		yourself
! !

!MessagePackMarshaler methodsFor:'private - writing'!

write: writing array: array
	self write: writing array_size: array size.
	array do: [:each | self marshal: writing object: each]
!

write: writing array_size: size
	size <= 2r00001111 ifTrue: [^writing uint8 put: size + 2r10010000].
	size <= 65535 ifTrue: [
		writing uint8 put: self class array16.
		^writing uint16 put: size].
	size <= 4294967295 ifTrue: [
		writing uint8 put: self class array32.
		^writing uint32 put: size].
	self error: 'array too big to marshal with MessagePack protocol'
!

write: writing integer: integer
	(integer between: 0 and: 127) ifTrue: [^writing uint8 put: integer].
	(integer between: -32 and: -1) ifTrue: [^writing uint8 put: integer + 256].
	integer >= 128 ifTrue: [
		integer <= 255 ifTrue: [^writing uint8 put: self class uint8; put: integer].
		integer <= 65535 ifTrue: [
			writing uint8 put: self class uint16.
			^writing uint16 put: integer].
		integer <= 4294967295 ifTrue: [
			writing uint8 put: self class uint32.
			^writing uint32 put: integer].
		integer <= 18446744073709551615 ifTrue: [
			writing uint8 put: self class uint64.
			^writing uint64 put: integer].
		self error: 'integer too big to marshal with MessagePack protocol'].
	integer >= -128 ifTrue: [
		writing uint8 put: self class int8.
		^writing int8 put: integer].
	integer >= -32768 ifTrue: [
		writing uint8 put: self class int16.
		^writing int16 put: integer].
	integer >= -2147483648 ifTrue: [
		writing uint8 put: self class int32.
		^writing int32 put: integer].
	integer >= -9223372036854775808 ifTrue: [
		writing uint8 put: self class int64.
		^writing int64 put: integer].
	self error: 'integer too small to marshal with MessagePack protocol'.
!

write: writing map: map
	self write: writing map_size: map size.
	map keysAndValuesDo: [:key :value |
		self marshal: writing object: key.
		self marshal: writing object: value]
!

write: writing map_size: size
	size <= 2r00001111 ifTrue: [^writing uint8 put: size + 2r10000000].
	size <= 65535 ifTrue: [
		writing uint8 put: self class map16.
		^writing uint16 put: size].
	size <= 4294967295 ifTrue: [
		writing uint8 put: self class map32.
		^writing uint32 put: size].
	self error: 'array too big to marshal with MessagePack protocol'
!

write: writing raw: bytearray
	self write: writing raw_size: bytearray size.
	writing uint8 write: bytearray
!

write: writing raw_size: size
	size <= 2r00011111 ifTrue: [^writing uint8 put: size + 2r10100000].
	size <= 65535 ifTrue: [
		writing uint8 put: self class raw16.
		^writing uint16 put: size].
	size <= 4294967295 ifTrue: [
		writing uint8 put: self class raw32.
		^writing uint32 put: size].
	self error: 'array too big to marshal with MessagePack protocol'
! !

!MessagePackMarshaler class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'
!

version_SVN
    ^ '$Id$'
! !