├── Demo ├── bench.dpr └── test.dpr ├── README.md └── msgpack.pas /Demo/bench.dpr: -------------------------------------------------------------------------------- 1 | program bench; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | Windows, 7 | SysUtils, 8 | superobject, 9 | msgpack in '..\msgpack.pas'; 10 | 11 | function GetTick: LongWord; 12 | var 13 | tick, freq: TLargeInteger; 14 | begin 15 | QueryPerformanceFrequency(freq); 16 | QueryPerformanceCounter(tick); 17 | Result := Trunc((tick / freq) * 1000); 18 | end; 19 | 20 | procedure BenchJson(); 21 | var 22 | js: ISuperObject; 23 | xs: ISuperObject; 24 | i, l: Integer; 25 | k: cardinal; 26 | s: SOString; 27 | json : UTF8String; 28 | ts: TSuperTableString; 29 | a: TSuperArray; 30 | begin 31 | Randomize; 32 | js := TSuperObject.Create; 33 | ts := js.AsObject; 34 | k := GetTick; 35 | for i := 1 to 100000 do 36 | begin 37 | l := i * 33; 38 | s := 'param' + IntToStr(l); 39 | ts.s[s] := s; 40 | s := 'int' + IntToStr(l); 41 | ts.i[s] := i; 42 | end; 43 | k := GetTick - k; 44 | Writeln('insert map: ', k); 45 | 46 | k := GetTick(); 47 | 48 | ts.O['array'] := TSuperObject.Create(stArray); 49 | a := ts.O['array'].AsArray; 50 | for i := 1 to 1000000 do 51 | a.Add(i); 52 | 53 | k := GetTick - k; 54 | Writeln('insert array: ', k); 55 | 56 | k := GetTick; 57 | json := UTF8Encode(js.AsJSon()); 58 | Writeln('dump: ', GetTick - k); 59 | Writeln('size utf8: ', Length(json)); 60 | 61 | k := GetTick; 62 | xs := TSuperObject.ParseString(PSOChar(UTF8Decode(json)), False); 63 | Writeln('parse: ', GetTick - k); 64 | 65 | k := GetTick; 66 | ts := xs.AsObject; 67 | for i := 1 to 100000 * 2 do 68 | begin 69 | l := i * 33; 70 | s := 'param' + IntToStr(l); 71 | ts.s[s]; 72 | 73 | l := i * 33; 74 | s := 'param' + IntToStr(l); 75 | ts.s[s]; 76 | end; 77 | Writeln('acess map: ', GetTick - k); 78 | end; 79 | 80 | procedure BenchMsgPack(); 81 | var 82 | js: IMsgPackObject; 83 | xs: IMsgPackObject; 84 | i, l: Integer; 85 | k: cardinal; 86 | s: string; 87 | ts: TMsgPackMap; 88 | Data: RawByteString; 89 | a: TMsgPackArray; 90 | begin 91 | Randomize; 92 | k := GetTick; 93 | js := TMsgPackObject.Create(mptMap); 94 | ts := js.AsMap; 95 | for i := 1 to 100000 do 96 | begin 97 | l := i * 33; 98 | s := 'param' + IntToStr(l); 99 | ts.Put(s, TMsgPackObject.Create(s)); 100 | s := 'int' + IntToStr(l); 101 | ts.Put(s, TMsgPackObject.Create(i)); 102 | end; 103 | Writeln('insert map:', GetTick - k); 104 | 105 | k := GetTick(); 106 | ts.Put('array', TMsgPackObject.Create(mptArray)); 107 | a := ts['array'].AsArray(); 108 | for i := 1 to 1000000 do 109 | a.Add(TMsgPackObject.Create(i * 33)); 110 | Writeln('insert array:', GetTick - k); 111 | 112 | k := GetTick; 113 | Data := js.AsMsgPack(); 114 | Writeln('dump: ', GetTick - k); 115 | Writeln('size: ', Length(Data)); 116 | 117 | k := GetTick; 118 | xs := TMsgPackObject.Parse(Data); 119 | Writeln('parse: ', GetTick - k); 120 | 121 | k := GetTick; 122 | ts := xs.AsMap; 123 | for i := 1 to 100000 * 2 do 124 | begin 125 | l := i * 33; 126 | s := 'param' + IntToStr(l); 127 | ts.Get(s); 128 | 129 | l := i * 33; 130 | s := 'param' + IntToStr(l); 131 | ts.Get(s); 132 | end; 133 | Writeln('access map: ', GetTick - k); 134 | end; 135 | 136 | var 137 | k : Cardinal; 138 | begin 139 | try 140 | Writeln('--- Json ---'); 141 | k := GetTick; 142 | BenchJson(); 143 | Writeln('total + cleanup: ', GetTick - k); 144 | 145 | 146 | Writeln('--- MsgPack ---'); 147 | k := GetTick; 148 | BenchMsgPack(); 149 | Writeln('total + cleanup: ', GetTick - k); 150 | 151 | except 152 | on E: Exception do 153 | begin 154 | Writeln(E.Message); 155 | end; 156 | end; 157 | readln; 158 | 159 | end. 160 | 161 | -------------------------------------------------------------------------------- /Demo/test.dpr: -------------------------------------------------------------------------------- 1 | program test; 2 | 3 | {$IFDEF FPC} 4 | {$MODE Delphi} 5 | {$ENDIF} 6 | 7 | {$ASSERTIONS ON} 8 | 9 | {$IFDEF WINDOWS} 10 | {$APPTYPE CONSOLE} 11 | {$ENDIF} 12 | 13 | {.$R *.res} 14 | 15 | uses 16 | {$IFNDEF FPC} 17 | Windows, 18 | {$ENDIF} 19 | SysUtils, 20 | Classes, 21 | MsgPack in '../msgpack.pas'; 22 | 23 | 24 | procedure TestMsgPack(); 25 | const 26 | // some ints 27 | Ints: array[0..23] of Int64 = (32216, Low(Int64), Low(Integer), Low(SmallInt), Low(ShortInt), -100, -10, -1, -2, 0, 28 | 1, 10, 100, 200, 1000, 3000, 30000, 300000, 3000000, High(ShortInt), High(SmallInt), High(Integer), High(cardinal), 29 | High(Int64)); 30 | var 31 | ob: IMsgPackObject; 32 | ar: TMsgPackArray; 33 | map: TMsgPackMap; 34 | s: Single; 35 | d: Double; 36 | i: Integer; 37 | n: Integer; 38 | nn: Int64; 39 | begin 40 | // test array with some ints 41 | ob := TMsgPackObject.Create(mptArray); 42 | ar := ob.AsArray(); 43 | for i := 0 to High(Ints) do 44 | ar.Add(MPO(Ints[i])); 45 | 46 | // test clone 47 | Assert(ob.Clone().AsMsgPack() = ob.AsMsgPack()); 48 | 49 | // parse the dump and check the integrity 50 | ob := TMsgPackObject.Parse(ob.AsMsgPack()); 51 | ar := ob.AsArray(); 52 | for i := 0 to High(Ints) do 53 | Assert(ar[i].AsInteger = Ints[i], IntToStr(i) + ' : ' + IntToStr(Ints[i]) + ' ' + IntToStr(ar[i].AsInteger())); 54 | 55 | // test double and single in a map 56 | s := Random; 57 | d := Random; 58 | ob := TMsgPackObject.Create(mptMap); 59 | map := ob.AsMap(); 60 | map['single'] := MPO(s); 61 | map['double'] := MPO(d); 62 | 63 | ob := TMsgPackObject.Parse(ob.AsMsgPack()); 64 | map := ob.AsMap(); 65 | Assert(s = map['single'].AsFloat(), FloatToStr(s) + ' ' + FloatToStr(map['single'].AsFloat())); 66 | Assert(d = map['double'].AsDouble(), FloatToStr(d) + ' ' + FloatToStr(map['double'].AsDouble())); 67 | 68 | // test clone 69 | Assert(ob.Clone().AsMsgPack() = ob.AsMsgPack()); 70 | 71 | // test map 72 | ob := TMsgPackObject.Create(mptMap); 73 | map := ob.AsMap(); 74 | for i := 0 to 100000 do 75 | begin 76 | map['key' + IntToStr(i)] := MPO('value' + IntToStr(i)); 77 | if i mod 31 = 0 then // i don't like multiples of 31, delete them :O 78 | map.Delete('key' + IntToStr(i)); 79 | end; 80 | 81 | ob := TMsgPackObject.Parse(ob.AsMsgPack()); 82 | map := ob.AsMap(); 83 | for i := 0 to 100000 do 84 | begin 85 | if i mod 31 = 0 then 86 | Assert(map['key' + IntToStr(i)] = nil) // make sure they're not there 87 | else 88 | Assert(map['key' + IntToStr(i)].AsString() = 'value' + IntToStr(i)); 89 | end; 90 | 91 | // make sure the int handling is good 92 | RandSeed := GetTickCount(); 93 | for i := 0 to 1000000 do 94 | begin 95 | n := Random(Integer(-1)); 96 | Assert(n = MPOFromMsgPack(MPO(n).AsMsgPack()).AsInteger, 97 | IntToStr(n) + ' ' + IntToStr(MPOFromMsgPack(MPO(n).AsMsgPack()).AsInteger)); 98 | end; 99 | 100 | for i := 0 to 1000000 do 101 | begin 102 | nn := (Int64(Random(Integer(-1))) shl 32) or Int64(Random(Integer(-1))); 103 | Assert(nn = MPOFromMsgPack(MPO(nn).AsMsgPack()).AsInteger, 104 | IntToStr(nn) + ' ' + IntToStr(MPOFromMsgPack(MPO(nn).AsMsgPack()).AsInteger)); 105 | end; 106 | 107 | Writeln('Test passed'); 108 | end; 109 | 110 | begin 111 | try 112 | TestMsgPack(); 113 | except 114 | on E: Exception do 115 | Writeln(E.ClassName, ': ', E.Message); 116 | end; 117 | Readln; 118 | end. 119 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | msgpack-delphi 2 | ============== 3 | From http://www.msgpack.org/ 4 | > MessagePack is an efficient binary serialization format. It lets you exchange data among multiple languages like JSON but it's faster and smaller. 5 | > For example, small integers (like flags or error code) are encoded into a single byte, and typical short strings only require an extra byte in addition to the strings themselves. 6 | > 7 | > If you ever wished to use JSON for convenience (storing an image with metadata) but could not for technical reasons (encoding, size, speed...), MessagePack is a perfect replacement. 8 | 9 | This Delphi-FPC implementation aims to be simple but still have good speed. 10 | 11 | * single unit 12 | * ~1350 lines 13 | * simple streaming suport (any TStream) 14 | * no external dependencies 15 | * load/parse ~2 times faster than equivalent JSON with superobject 16 | 17 | It also uses Interfaced objects to provide a simple Garbage Collector mechanism, so no need to call .Free or handle cloning manually in your program. 18 | 19 | Specification conformance 20 | -------- 21 | 22 | It supports the latest msgpack 2.0 specification except ext type (Extension type). 23 | 24 | Map Keys 25 | -------- 26 | 27 | MsgPack has no limitations for the type of map keys, they can be anything including other maps. The unit has two configurations defined with the *STRINGMAPKEYS* conditional directive at the top of the unit. 28 | 29 | * STRINGMAPKEYS Enabled: Maps allows only bytes of string keys. An exception is raised if something else is found as a key. Map operations are usually 2x faster. 30 | * STRINGMAPKEYS Disabled: Map keys can be any type. 31 | 32 | Works with 33 | -------- 34 | 35 | * Delphi 7 (tested) 36 | * Delphi 2009-XE (not tested) 37 | * Delphi XE2 (tested) 38 | * Delphi XE3-5 (not tested) 39 | * FPC (tested) 40 | 41 | Included 42 | -------- 43 | 44 | * Benchmark against Json (using superobject) 45 | * Very simple test program. 46 | 47 | To-Do 48 | -------- 49 | 50 | Documentation 51 | 52 | Comprehensive tests 53 | -------------------------------------------------------------------------------- /msgpack.pas: -------------------------------------------------------------------------------- 1 | {* 2 | * Delphi MsgPack 3 | * 4 | * Usage allowed under the restrictions of the Lesser GNU General Public License 5 | * or alternatively the restrictions of the Mozilla Public License 1.1 6 | * 7 | * Software distributed under the License is distributed on an "AS IS" basis, 8 | * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for 9 | * the specific language governing rights and limitations under the License. 10 | * 11 | * Embarcadero Technologies Inc is not permitted to use or redistribute 12 | * this source code without explicit permission. 13 | * 14 | * Unit owner : Arthur Pires Ribeiro Silva 15 | * Web site : https://github.com/arthurprs/msgpack-delphi 16 | * 17 | * The implementation prefers simplicity and correctness over speed (still decently fast). 18 | * 19 | * Inspiration: http://code.google.com/p/superobject/ 20 | *} 21 | 22 | unit msgpack; 23 | 24 | {$IFDEF FPC} 25 | {$MODE DELPHI} 26 | {$ENDIF} 27 | 28 | interface 29 | 30 | uses 31 | SysUtils, Classes; 32 | 33 | {$IFDEF FPC} 34 | {$DEFINE HAVE_INLINE} 35 | {$ELSE} 36 | {$WARN UNSAFE_CAST OFF} 37 | {$WARN UNSAFE_CODE OFF} 38 | {$WARN UNSAFE_TYPE OFF} 39 | {$WARN HIDDEN_VIRTUAL OFF} 40 | {$IF CompilerVersion >= 17} 41 | {$DEFINE HAVE_INLINE} 42 | {$IFEND} 43 | {$ENDIF} 44 | 45 | // Define to restrict map keys to strings (like json). Usual map operations will run at 2x+ the speed. 46 | {$DEFINE STRINGMAPKEYS} 47 | 48 | type 49 | {$IFNDEF UNICODE} 50 | RawByteString = AnsiString; 51 | UnicodeString = WideString; 52 | {$ENDIF} 53 | IMsgPackObject = interface; 54 | TMsgPackObject = class; 55 | 56 | TMsgPackType = (mptNil = 0, mptBoolean, mptInteger, mptFloat, mptDouble, mptString, mptBytes, mptArray, mptMap); 57 | 58 | TMsgPackArray = class 59 | private 60 | FItems: TInterfaceList; 61 | FCount: Integer; 62 | public 63 | constructor Create(); 64 | destructor Destroy; override; 65 | procedure Clear(); 66 | function Add(const Item: IMsgPackObject): Integer; 67 | function Get(const Index: Integer): IMsgPackObject; 68 | procedure Delete(const Index: Integer); 69 | procedure Put(const Index: Integer; const Value: IMsgPackObject); 70 | property Items[const index: Integer]: IMsgPackObject read Get write Put; default; 71 | property Count: Integer read FCount; 72 | end; 73 | 74 | TMsgPackMapKey = {$IFDEF STRINGMAPKEYS}UnicodeString{$ELSE}IMsgPackObject{$ENDIF}; 75 | 76 | TMsgPackMapIterator = record 77 | FCursor: Integer; 78 | Key: TMsgPackMapKey; 79 | Value: IMsgPackObject; 80 | end; 81 | 82 | TMsgPackMapBucket = record 83 | Key: TMsgPackMapKey; 84 | Value: IMsgPackObject; 85 | end; 86 | 87 | PMsgPackMapBucket = ^TMsgPackMapBucket; 88 | TMsgPackMapBuckets = array of TMsgPackMapBucket; 89 | 90 | TMsgPackMap = class 91 | private 92 | FCount: Integer; 93 | FCapacity: Integer; 94 | FBuckets: TMsgPackMapBuckets; 95 | // double the hashtable size 96 | procedure Grow(); 97 | // Return the bucket containing the key or the bucket where it could be inserted 98 | function FindBucket(const Key: TMsgPackMapKey): PMsgPackMapBucket; 99 | procedure InternalPut(const Key: TMsgPackMapKey; const Value: IMsgPackObject); 100 | function InternalGet(const Key: TMsgPackMapKey): IMsgPackObject; 101 | procedure InternalDelete(const Key: TMsgPackMapKey); 102 | public 103 | constructor Create(); 104 | destructor Destroy; override; 105 | procedure Clear(); 106 | function Get(const Key: UnicodeString): IMsgPackObject; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 107 | procedure Put(const Key: UnicodeString; const Value: IMsgPackObject); {$IFDEF HAVE_INLINE}inline; {$ENDIF} 108 | procedure Delete(const Key: UnicodeString); {$IFDEF HAVE_INLINE}inline; {$ENDIF} 109 | {$IFNDEF STRINGMAPKEYS} 110 | procedure PutEx(const Key, Value: IMsgPackObject); {$IFDEF HAVE_INLINE}inline; {$ENDIF} 111 | function GetEx(const Key: IMsgPackObject): IMsgPackObject; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 112 | procedure DeleteEx(const Key: IMsgPackObject); {$IFDEF HAVE_INLINE}inline; {$ENDIF} 113 | {$ENDIF} 114 | procedure IteratorInit(var Iterator: TMsgPackMapIterator); {$IFDEF HAVE_INLINE}inline; {$ENDIF} 115 | function IteratorAdvance(var Iterator: TMsgPackMapIterator): Boolean; 116 | property Count: Integer read FCount; 117 | property Values[const Key: UnicodeString]: IMsgPackObject read Get write Put; default; 118 | end; 119 | 120 | IMsgPackObject = interface 121 | ['{FAC2A072-C1D1-46A3-BD2F-9F9050FD1E1F}'] 122 | // type 123 | function GetObjectType: TMsgPackType; 124 | property ObjectType: TMsgPackType read GetObjectType; 125 | // conversions 126 | function AsNil: Boolean; 127 | function AsBoolean: Boolean; 128 | function AsInteger: Int64; 129 | function AsDouble: Double; 130 | function AsFloat: Single; 131 | function AsBytes: RawByteString; 132 | function AsString: UnicodeString; 133 | function AsArray: TMsgPackArray; 134 | function AsMap: TMsgPackMap; 135 | // equality 136 | function Equals(const Other: IMsgPackObject): Boolean; 137 | {$IFNDEF STRINGMAPKEYS} 138 | function HashCode(): Cardinal; 139 | {$ENDIF} 140 | // clone 141 | function Clone(): IMsgPackObject; 142 | // dump 143 | function AsMsgPack(): RawByteString; 144 | procedure Write(const Stream: TStream); 145 | // parse 146 | procedure Read(const Stream: TStream); 147 | end; 148 | 149 | TMsgPackVariant = record 150 | case TMsgPackType of 151 | mptBoolean: 152 | (dataBoolean: Boolean); 153 | mptInteger: 154 | (dataInteger: Int64); 155 | mptFloat: 156 | (dataFloat: Single); 157 | mptDouble: 158 | (dataDouble: Double); 159 | mptArray: 160 | (dataArray: TMsgPackArray); 161 | mptMap: 162 | (dataMap: TMsgPackMap); 163 | end; 164 | 165 | TMsgPackObject = class(TInterfacedObject, IMsgPackObject) 166 | private 167 | FType: TMsgPackType; 168 | FVariant: TMsgPackVariant; 169 | FBytes: RawByteString; 170 | FString: UnicodeString; 171 | public 172 | destructor Destroy; override; 173 | // creating new objects 174 | constructor Create(); overload; // create as nil 175 | constructor Create(const ObjectType: TMsgPackType); overload; 176 | constructor Create(const Value: Boolean); overload; 177 | constructor Create(const Value: Int64); overload; 178 | constructor Create(const Value: Single); overload; 179 | constructor Create(const Value: Double); overload; 180 | constructor Create(const Value: RawByteString); overload; 181 | constructor Create(const Value: UnicodeString); overload; 182 | // parsing 183 | constructor Parse(const Str: RawByteString); overload; 184 | constructor Parse(const Stream: TStream); overload; 185 | // type 186 | function GetObjectType: TMsgPackType; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 187 | property ObjectType: TMsgPackType read GetObjectType; 188 | // casts 189 | function AsNil: Boolean; 190 | function AsBoolean: Boolean; 191 | function AsInteger: Int64; 192 | function AsDouble: Double; 193 | function AsFloat: Single; 194 | function AsBytes: RawByteString; 195 | function AsString: UnicodeString; 196 | function AsArray: TMsgPackArray; 197 | function AsMap: TMsgPackMap; 198 | // equality 199 | function {%H-}Equals(const Other: IMsgPackObject): Boolean; 200 | // clone 201 | function Clone(): IMsgPackObject; 202 | {$IFNDEF STRINGMAPKEYS} 203 | function HashCode(): Cardinal; 204 | {$ENDIF} 205 | // dump 206 | function AsMsgPack(): RawByteString; 207 | procedure Write(const Stream: TStream); 208 | // parse 209 | procedure Read(const Stream: TStream); 210 | end; 211 | 212 | function MPO(const Value: Boolean): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 213 | function MPO(const Value: Int64): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 214 | function MPO(const Value: Single): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 215 | function MPO(const Value: Double): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 216 | function MPO(const Value: RawByteString): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 217 | function MPO(const Value: UnicodeString): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 218 | function MPO(const ObjectType: TMsgPackType): IMsgPackObject; overload; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 219 | function MPOFromMsgPack(const Str: RawByteString): IMsgPackObject; {$IFDEF HAVE_INLINE}inline; {$ENDIF} 220 | 221 | implementation 222 | 223 | {$IFNDEF UNICODE} 224 | function UTF8ToUnicodeString(const Str: RawByteString): UnicodeString; 225 | begin 226 | Result := Utf8Decode(Str); 227 | end; 228 | {$ENDIF} 229 | 230 | function MPOFromMsgPack(const Str: RawByteString): IMsgPackObject; 231 | begin 232 | Result := TMsgPackObject.Parse(Str); 233 | end; 234 | 235 | function MPO(const Value: Boolean): IMsgPackObject; 236 | begin 237 | Result := TMsgPackObject.Create(Value); 238 | end; 239 | 240 | function MPO(const Value: Int64): IMsgPackObject; 241 | begin 242 | Result := TMsgPackObject.Create(Value); 243 | end; 244 | 245 | function MPO(const Value: Single): IMsgPackObject; 246 | begin 247 | Result := TMsgPackObject.Create(Value); 248 | end; 249 | 250 | function MPO(const Value: Double): IMsgPackObject; 251 | begin 252 | Result := TMsgPackObject.Create(Value); 253 | end; 254 | 255 | function MPO(const Value: RawByteString): IMsgPackObject; 256 | begin 257 | Result := TMsgPackObject.Create(Value); 258 | end; 259 | 260 | function MPO(const Value: UnicodeString): IMsgPackObject; 261 | begin 262 | Result := TMsgPackObject.Create(Value); 263 | end; 264 | 265 | function MPO(const ObjectType: TMsgPackType): IMsgPackObject; 266 | begin 267 | Result := TMsgPackObject.Create(ObjectType); 268 | end; 269 | 270 | { TMsgPackMap } 271 | 272 | var 273 | DeletedBucketValue: IMsgPackObject; 274 | 275 | {$IFNDEF STRINGMAPKEYS} 276 | function HashBytes(const Key: RawByteString): Cardinal; 277 | var 278 | i: Integer; 279 | begin 280 | // FVN1-a 281 | Result := 2166136261; 282 | for i := 1 to Length(Key) do 283 | Result := (Result xor Ord(Key[i])) * 16777619; 284 | end; 285 | {$ENDIF} 286 | 287 | function HashString(const Key: UnicodeString): Cardinal; 288 | var 289 | i: Integer; 290 | begin 291 | // (1 char) 2 bytes at a time 292 | Result := 2166136261; 293 | for i := 1 to Length(Key) do 294 | Result := (Result xor Ord(Key[i])) * 16777619; 295 | end; 296 | 297 | procedure TMsgPackMap.InternalPut(const Key: TMsgPackMapKey; const Value: IMsgPackObject); 298 | var 299 | bucket: PMsgPackMapBucket; 300 | begin 301 | if FCount >= (FCapacity div 3) * 2 then 302 | Grow(); 303 | 304 | bucket := FindBucket(Key); 305 | if (bucket.Value = nil) or (bucket.Value = DeletedBucketValue) then 306 | begin 307 | // new entry 308 | Inc(FCount); 309 | bucket.Key := Key; 310 | bucket.Value := Value; 311 | end 312 | else 313 | begin 314 | // replace 315 | bucket.Value := Value; 316 | end; 317 | end; 318 | 319 | procedure TMsgPackMap.Clear; 320 | begin 321 | SetLength(FBuckets, 0); 322 | FCount := 0; 323 | end; 324 | 325 | constructor TMsgPackMap.Create; 326 | begin 327 | 328 | end; 329 | 330 | procedure TMsgPackMap.InternalDelete(const Key: TMsgPackMapKey); 331 | var 332 | bucket: PMsgPackMapBucket; 333 | begin 334 | bucket := FindBucket(Key); 335 | {$IFDEF STRINGMAPKEYS} 336 | if bucket.Key = Key then 337 | {$ELSE} 338 | if (bucket.Key <> nil) and bucket.Key.Equals(Key) then 339 | {$ENDIF} 340 | begin 341 | bucket.Key := {$IFDEF STRINGMAPKEYS}''{$ELSE}nil{$ENDIF}; 342 | bucket.Value := DeletedBucketValue; 343 | Dec(FCount); 344 | end; 345 | end; 346 | 347 | destructor TMsgPackMap.Destroy; 348 | begin 349 | 350 | end; 351 | 352 | function TMsgPackMap.InternalGet(const Key: TMsgPackMapKey): IMsgPackObject; 353 | var 354 | bucket: PMsgPackMapBucket; 355 | begin 356 | Result := nil; 357 | if FCount = 0 then 358 | Exit; 359 | bucket := FindBucket(Key); 360 | if {$IFDEF STRINGMAPKEYS}bucket.Key = Key{$ELSE} 361 | (bucket.Key <> nil) and bucket.Key.Equals(Key){$ENDIF} then 362 | Result := bucket.Value; 363 | end; 364 | 365 | procedure TMsgPackMap.IteratorInit(var Iterator: TMsgPackMapIterator); 366 | begin 367 | Iterator.FCursor := -1; 368 | end; 369 | 370 | function TMsgPackMap.IteratorAdvance(var Iterator: TMsgPackMapIterator): Boolean; 371 | begin 372 | Result := False; 373 | Inc(Iterator.FCursor); 374 | while Iterator.FCursor < FCapacity do 375 | begin 376 | if (FBuckets[Iterator.FCursor].Value <> nil) and 377 | (FBuckets[Iterator.FCursor].Value <> DeletedBucketValue) then 378 | begin 379 | Iterator.Key := FBuckets[Iterator.FCursor].Key; 380 | Iterator.Value := FBuckets[Iterator.FCursor].Value; 381 | Result := True; 382 | Exit; 383 | end; 384 | Inc(Iterator.FCursor); 385 | end; 386 | end; 387 | 388 | procedure TMsgPackMap.Grow(); 389 | var 390 | oldCapacity: Integer; 391 | oldBuckets: TMsgPackMapBuckets; 392 | i: Integer; 393 | begin 394 | oldCapacity := FCapacity; 395 | oldBuckets := FBuckets; 396 | 397 | if oldCapacity = 0 then 398 | FCapacity := 32 399 | else 400 | FCapacity := oldCapacity * 2; 401 | 402 | SetLength(FBuckets, 0); 403 | SetLength(FBuckets, FCapacity); 404 | FCount := 0; // reset 405 | 406 | for i := 0 to oldCapacity - 1 do 407 | begin 408 | if (oldBuckets[i].Value <> nil) and (oldBuckets[i].Value <> DeletedBucketValue) then 409 | InternalPut(oldBuckets[i].Key, oldBuckets[i].Value); 410 | end; 411 | end; 412 | 413 | function TMsgPackMap.FindBucket(const Key: TMsgPackMapKey): PMsgPackMapBucket; 414 | var 415 | hash: Cardinal; 416 | begin 417 | hash := {$IFDEF STRINGMAPKEYS}HashString(Key){$ELSE}Key.HashCode(){$ENDIF} and (FCapacity - 1); // apply mask 418 | Result := @FBuckets[hash]; 419 | while (FBuckets[hash].Value <> nil) and (FBuckets[hash].Value <> DeletedBucketValue) do 420 | begin 421 | if {$IFDEF STRINGMAPKEYS}FBuckets[hash].Key = Key{$ELSE} 422 | (FBuckets[hash].Key <> nil) and FBuckets[hash].Key.Equals(Key){$ENDIF} then 423 | Exit; 424 | hash := (hash + 1) and (FCapacity - 1); 425 | Result := @FBuckets[hash]; 426 | end; 427 | end; 428 | 429 | procedure TMsgPackMap.Put(const Key: UnicodeString; const Value: IMsgPackObject); 430 | begin 431 | InternalPut({$IFDEF STRINGMAPKEYS}Key{$ELSE}MPO(Key){$ENDIF}, Value); 432 | end; 433 | 434 | procedure TMsgPackMap.Delete(const Key: UnicodeString); 435 | begin 436 | InternalDelete({$IFDEF STRINGMAPKEYS}Key{$ELSE}MPO(Key){$ENDIF}); 437 | end; 438 | 439 | function TMsgPackMap.Get(const Key: UnicodeString): IMsgPackObject; 440 | begin 441 | Result := InternalGet({$IFDEF STRINGMAPKEYS}Key{$ELSE}MPO(Key){$ENDIF}); 442 | end; 443 | 444 | {$IFNDEF STRINGMAPKEYS} 445 | procedure TMsgPackMap.PutEx(const Key: IMsgPackObject; const Value: IMsgPackObject); 446 | begin 447 | InternalPut(Key, Value); 448 | end; 449 | 450 | procedure TMsgPackMap.DeleteEx(const Key: IMsgPackObject); 451 | begin 452 | InternalDelete(Key); 453 | end; 454 | 455 | function TMsgPackMap.GetEx(const Key: IMsgPackObject): IMsgPackObject; 456 | begin 457 | Result := InternalGet(Key); 458 | end; 459 | {$ENDIF} 460 | 461 | { TMsgPackArray } 462 | 463 | function TMsgPackArray.Add(const Item: IMsgPackObject): Integer; 464 | begin 465 | Inc(FCount); 466 | Result := FItems.Add(Item); 467 | end; 468 | 469 | procedure TMsgPackArray.Clear; 470 | begin 471 | FItems.Clear(); 472 | FCount := 0; 473 | end; 474 | 475 | constructor TMsgPackArray.Create; 476 | begin 477 | FItems := TInterfaceList.Create; 478 | end; 479 | 480 | procedure TMsgPackArray.Delete(const Index: Integer); 481 | begin 482 | FItems.Delete(Index); 483 | Dec(FCount); 484 | end; 485 | 486 | destructor TMsgPackArray.Destroy; 487 | begin 488 | Clear(); 489 | FItems.Free; 490 | end; 491 | 492 | function TMsgPackArray.Get(const Index: Integer): IMsgPackObject; 493 | begin 494 | Result := IMsgPackObject(FItems[Index]); 495 | end; 496 | 497 | procedure TMsgPackArray.Put(const Index: Integer; const Value: IMsgPackObject); 498 | begin 499 | FItems.Insert(Index, Value); 500 | end; 501 | 502 | { TMsgPackObject } 503 | 504 | function TMsgPackObject.AsArray: TMsgPackArray; 505 | begin 506 | case FType of 507 | mptNil: 508 | Result := nil; 509 | mptArray: 510 | Result := FVariant.dataArray; 511 | else 512 | raise EInvalidCast.Create('Invalid cast'); 513 | end; 514 | end; 515 | 516 | function TMsgPackObject.AsBoolean: Boolean; 517 | begin 518 | case FType of 519 | mptNil: 520 | Result := False; 521 | mptBoolean: 522 | Result := FVariant.dataBoolean; 523 | mptInteger: 524 | Result := FVariant.dataInteger <> 0; 525 | mptFloat: 526 | Result := FVariant.dataFloat <> 0.0; 527 | mptDouble: 528 | Result := FVariant.dataDouble <> 0.0; 529 | mptArray: 530 | Result := FVariant.dataArray.Count <> 0; 531 | mptMap: 532 | Result := FVariant.dataMap.Count <> 0; 533 | else 534 | raise EInvalidCast.Create('Invalid cast'); 535 | end; 536 | end; 537 | 538 | function TMsgPackObject.AsBytes: RawByteString; 539 | begin 540 | case FType of 541 | mptNil: 542 | Result := ''; 543 | mptBytes: 544 | Result := FBytes; 545 | mptString: 546 | Result := UTF8Encode(FString) 547 | else 548 | raise EInvalidCast.Create('Invalid cast'); 549 | end; 550 | end; 551 | 552 | function TMsgPackObject.AsDouble: Double; 553 | begin 554 | case FType of 555 | mptNil: 556 | Result := 0; 557 | mptInteger: 558 | Result := FVariant.dataInteger; 559 | mptFloat: 560 | Result := FVariant.dataFloat; 561 | mptDouble: 562 | Result := FVariant.dataDouble; 563 | else 564 | raise EInvalidCast.Create('Invalid cast'); 565 | end; 566 | end; 567 | 568 | function TMsgPackObject.AsFloat: Single; 569 | begin 570 | case FType of 571 | mptNil: 572 | Result := 0; 573 | mptInteger: 574 | Result := FVariant.dataInteger; 575 | mptFloat: 576 | Result := FVariant.dataFloat; 577 | mptDouble: 578 | Result := FVariant.dataDouble; 579 | else 580 | raise EInvalidCast.Create('Invalid cast'); 581 | end; 582 | end; 583 | 584 | function TMsgPackObject.AsInteger: Int64; 585 | begin 586 | case FType of 587 | mptNil: 588 | Result := 0; 589 | mptBoolean: 590 | if FVariant.dataBoolean then 591 | Result := 1 592 | else 593 | Result := 0; 594 | mptInteger: 595 | Result := FVariant.dataInteger; 596 | mptFloat: 597 | Result := Trunc(FVariant.dataFloat); 598 | mptDouble: 599 | Result := Trunc(FVariant.dataDouble); 600 | else 601 | raise EInvalidCast.Create('Invalid cast'); 602 | end; 603 | end; 604 | 605 | function TMsgPackObject.AsNil: Boolean; 606 | begin 607 | Result := FType = mptNil; 608 | end; 609 | 610 | function TMsgPackObject.AsString: UnicodeString; 611 | begin 612 | case FType of 613 | mptNil: 614 | Result := ''; 615 | mptBytes: 616 | {$IFDEF UNICODE} 617 | Result := UTF8ToUnicodeString(FBytes); 618 | {$ELSE} 619 | Result := UTF8Decode(FBytes); 620 | {$ENDIF} 621 | mptString: 622 | Result := FString; 623 | else 624 | raise EInvalidCast.Create('Invalid cast'); 625 | end; 626 | end; 627 | 628 | function TMsgPackObject.AsMap: TMsgPackMap; 629 | begin 630 | case FType of 631 | mptNil: 632 | Result := nil; 633 | mptMap: 634 | Result := FVariant.dataMap; 635 | else 636 | raise EInvalidCast.Create('Invalid cast'); 637 | end; 638 | end; 639 | 640 | constructor TMsgPackObject.Create; 641 | begin 642 | FType := mptNil; 643 | end; 644 | 645 | constructor TMsgPackObject.Create(const Value: Single); 646 | begin 647 | FType := mptFloat; 648 | FVariant.dataFloat := Value; 649 | end; 650 | 651 | constructor TMsgPackObject.Create(const Value: Int64); 652 | begin 653 | FType := mptInteger; 654 | FVariant.dataInteger := Value; 655 | end; 656 | 657 | constructor TMsgPackObject.Create(const Value: Boolean); 658 | begin 659 | FType := mptBoolean; 660 | FVariant.dataBoolean := Value; 661 | end; 662 | 663 | constructor TMsgPackObject.Create(const Value: Double); 664 | begin 665 | FType := mptDouble; 666 | FVariant.dataDouble := Value; 667 | end; 668 | 669 | constructor TMsgPackObject.Create(const Value: RawByteString); 670 | begin 671 | FType := mptBytes; 672 | FBytes := Value; 673 | end; 674 | 675 | constructor TMsgPackObject.Create(const ObjectType: TMsgPackType); 676 | begin 677 | FType := ObjectType; 678 | case FType of 679 | mptArray: 680 | FVariant.dataArray := TMsgPackArray.Create; 681 | mptMap: 682 | FVariant.dataMap := TMsgPackMap.Create; 683 | end; 684 | end; 685 | 686 | constructor TMsgPackObject.Create(const Value: UnicodeString); 687 | begin 688 | FType := mptString; 689 | FString := Value; 690 | end; 691 | 692 | destructor TMsgPackObject.Destroy; 693 | begin 694 | case FType of 695 | mptArray: 696 | FVariant.dataArray.Free; 697 | mptMap: 698 | FVariant.dataMap.Free; 699 | end; 700 | inherited; 701 | end; 702 | 703 | function TMsgPackObject.AsMsgPack: RawByteString; 704 | var 705 | resultStream: TMemoryStream; 706 | begin 707 | resultStream := TMemoryStream.Create(); 708 | try 709 | Write(resultStream); 710 | SetLength(Result, resultStream.Size); 711 | Move(resultStream.Memory^, Pointer(Result)^, resultStream.Size); 712 | finally 713 | resultStream.Free; 714 | end; 715 | end; 716 | 717 | procedure TMsgPackObject.Write(const Stream: TStream); 718 | 719 | procedure WriteByte(Value: Byte); 720 | begin 721 | Stream.Write(Value, 1); 722 | end; 723 | 724 | procedure WriteBEWord(Value: Word); 725 | begin 726 | Value := ((Value and $00FF) shl 8) or ((Value and $FF00) shr 8); 727 | Stream.Write(Value, 2); 728 | end; 729 | 730 | procedure WriteBEDWord(Value: Cardinal); 731 | begin 732 | Value := ((Value and $000000FF) shl 24) or ((Value and $0000FF00) shl 8) or 733 | ((Value and $00FF0000) shr 8) or ((Value and $FF000000) shr 24); 734 | Stream.Write(Value, 4); 735 | end; 736 | 737 | procedure WriteBEQWord(Value: Int64); 738 | var 739 | i: Integer; 740 | bytes: array[0..7] of Byte absolute Value; 741 | begin 742 | // definitely need some tunning.. 743 | for i := 7 downto 0 do 744 | Stream.Write(bytes[i], 1); 745 | end; 746 | 747 | procedure WriteBytes(const Value: RawByteString); 748 | begin 749 | case Length(Value) of 750 | 0..High(Byte): 751 | begin // uint8 752 | WriteByte($C4); 753 | WriteByte(Length(Value)); 754 | end; 755 | High(Byte) + 1..High(Word): 756 | begin 757 | WriteByte($C5); // uint16 758 | WriteBEWord(Length(Value)); 759 | end; 760 | else 761 | begin 762 | WriteByte($C6); // uint32 763 | WriteBEDWord(Length(Value)); 764 | end; 765 | end; 766 | Stream.Write(Pointer(Value)^, Length(Value)); 767 | end; 768 | 769 | procedure WriteString(const Value: UnicodeString); 770 | var 771 | utf8str: UTF8String; 772 | begin 773 | utf8str := UTF8Encode(Value); 774 | case Length(utf8str) of 775 | 0..31: 776 | begin // fixstr 777 | WriteByte($A0 or Length(utf8str)); 778 | end; 779 | 32..High(Byte): 780 | begin 781 | WriteByte($D9); 782 | WriteByte(Length(utf8str)) 783 | end; 784 | High(Byte) + 1..High(Word): 785 | begin 786 | WriteByte($DA); // uint16 787 | WriteBEWord(Length(utf8str)); 788 | end; 789 | else 790 | begin 791 | WriteByte($DB); // uint32 792 | WriteBEDWord(Length(utf8str)); 793 | end; 794 | end; 795 | Stream.Write(Pointer(utf8str)^, Length(utf8str)); 796 | end; 797 | 798 | procedure WriteArray(); 799 | var 800 | i: Integer; 801 | begin 802 | // write the prefix 803 | case FVariant.dataArray.Count of 804 | 0..15: 805 | begin 806 | WriteByte($90 or FVariant.dataArray.Count); 807 | end; 808 | 16..High(Word): 809 | begin 810 | WriteByte($DC); // uint16 811 | WriteBEWord(FVariant.dataArray.Count); 812 | end; 813 | else 814 | begin 815 | WriteByte($DD); // uint32 816 | WriteBEDWord(FVariant.dataArray.Count); 817 | end; 818 | end; 819 | // write the items 820 | for i := 0 to FVariant.dataArray.Count - 1 do 821 | FVariant.dataArray.Get(i).Write(Stream); 822 | end; 823 | 824 | procedure WriteMap(); 825 | var 826 | mapIt: TMsgPackMapIterator; 827 | begin 828 | begin 829 | // write the prefix 830 | case FVariant.dataMap.Count of 831 | 0..15: 832 | begin 833 | WriteByte($80 or FVariant.dataMap.Count); 834 | end; 835 | 16..High(Word): 836 | begin 837 | WriteByte($DE); // uint16 838 | WriteBEWord(FVariant.dataMap.Count); 839 | end; 840 | else 841 | begin 842 | WriteByte($DF); // uint32 843 | WriteBEDWord(FVariant.dataMap.Count); 844 | end; 845 | end; 846 | // write the pairs 847 | FVariant.dataMap.IteratorInit(mapIt{%H-}); 848 | while FVariant.dataMap.IteratorAdvance(mapIt) do 849 | begin 850 | {$IFDEF STRINGMAPKEYS} 851 | WriteString(mapIt.Key); 852 | {$ELSE} 853 | mapIt.Key.Write(Stream); 854 | {$ENDIF} 855 | mapIt.Value.Write(Stream); 856 | end; 857 | end; 858 | end; 859 | 860 | begin 861 | case FType of 862 | mptNil: 863 | begin 864 | WriteByte($C0); // nil 865 | end; 866 | mptBoolean: 867 | begin 868 | if FVariant.dataBoolean then 869 | WriteByte($C3) // true 870 | else 871 | WriteByte($C2); // false 872 | end; 873 | mptInteger: 874 | begin 875 | if (FVariant.dataInteger >= 0) and (FVariant.dataInteger <= 127) then 876 | begin 877 | WriteByte(Byte(FVariant.dataInteger)); // pos fixnum 878 | end 879 | else if (FVariant.dataInteger >= -32) and (FVariant.dataInteger <= -1) then 880 | begin 881 | WriteByte($11100000 or Byte(FVariant.dataInteger)); // neg fixnum 882 | end 883 | else if (FVariant.dataInteger >= 127 + 1) and (FVariant.dataInteger <= High(Byte)) then 884 | begin 885 | WriteByte($CC); // uint8 886 | WriteByte(Byte(FVariant.dataInteger)); 887 | end 888 | else if (FVariant.dataInteger >= High(Byte) + 1) and (FVariant.dataInteger <= High(Word)) then 889 | begin 890 | WriteByte($CD); // uint16 891 | WriteBEWord(Word(FVariant.dataInteger)); 892 | end 893 | else if (FVariant.dataInteger >= High(Word) + 1) and (FVariant.dataInteger <= High(Cardinal)) then 894 | begin 895 | WriteByte($CE); // uint32 896 | WriteBEDWord(Cardinal(FVariant.dataInteger)); 897 | end 898 | else if (FVariant.dataInteger >= Low(ShortInt)) and (FVariant.dataInteger <= -32 - 1) then 899 | begin 900 | WriteByte($D0); // int8 901 | WriteByte(ShortInt(FVariant.dataInteger)); 902 | end 903 | else if (FVariant.dataInteger >= Low(SmallInt)) and (FVariant.dataInteger <= Low(ShortInt) - 1) then 904 | begin 905 | WriteByte($D1); // int16 906 | WriteBEWord(SmallInt(FVariant.dataInteger)); 907 | end 908 | else if (FVariant.dataInteger >= Low(Integer)) and (FVariant.dataInteger <= Low(SmallInt) - 1) then 909 | begin 910 | WriteByte($D2); // int32 911 | WriteBEDWord(Integer(FVariant.dataInteger)); 912 | end 913 | else 914 | begin 915 | WriteByte($D3); // int64 916 | WriteBEQWord(FVariant.dataInteger); 917 | end; 918 | end; 919 | mptFloat: 920 | begin 921 | WriteByte($CA); // float 922 | WriteBEDWord(PCardinal(@FVariant.dataFloat)^); 923 | end; 924 | mptDouble: 925 | begin 926 | WriteByte($CB); // double 927 | WriteBEQWord(PInt64(@FVariant.dataDouble)^); 928 | end; 929 | mptArray: 930 | WriteArray(); 931 | mptMap: 932 | WriteMap(); 933 | mptBytes: 934 | WriteBytes(FBytes); 935 | mptString: 936 | WriteString(FString); 937 | end; 938 | end; 939 | 940 | function TMsgPackObject.GetObjectType: TMsgPackType; 941 | begin 942 | Result := FType; 943 | end; 944 | 945 | constructor TMsgPackObject.Parse(const Str: RawByteString); 946 | var 947 | Stream: TMemoryStream; 948 | begin 949 | Stream := TMemoryStream.Create; 950 | try 951 | Stream.Size := Length(Str); 952 | Move(Pointer(Str)^, Pointer(Stream.Memory)^, Stream.Size); 953 | Read(Stream); 954 | finally 955 | Stream.Free; 956 | end; 957 | end; 958 | 959 | procedure TMsgPackObject.Read(const Stream: TStream); 960 | 961 | function ReadByte(): Byte; 962 | begin 963 | Stream.ReadBuffer(Result{%H-}, 1); 964 | end; 965 | 966 | function ReadBEWord(): Word; 967 | begin 968 | Stream.ReadBuffer(Result{%H-}, 2); 969 | Result := ((Result and $00FF) shl 8) or ((Result and $FF00) shr 8); 970 | end; 971 | 972 | function ReadBEDWord(): Cardinal; 973 | begin 974 | Stream.ReadBuffer(Result{%H-}, 4); 975 | Result := ((Result and $000000FF) shl 24) or ((Result and $0000FF00) shl 8) or 976 | ((Result and $00FF0000) shr 8) or ((Result and $FF000000) shr 24); 977 | end; 978 | 979 | function ReadBEQWord(): Int64; 980 | var 981 | i: Integer; 982 | bytes: array[0..7] of Byte absolute Result; 983 | begin 984 | // definitely need some tunning.. 985 | for i := 7 downto 0 do 986 | Stream.ReadBuffer(bytes{%H-}[i], 1); 987 | end; 988 | 989 | function ReadString(const Len: Integer): UnicodeString; 990 | var 991 | readLen: Integer; 992 | utf8Str: UTF8String; 993 | begin 994 | // read bytes 995 | SetLength(utf8Str, Len); 996 | readLen := Stream.Read(Pointer(utf8Str)^, Len); 997 | if readLen <> Len then 998 | raise EReadError.CreateFmt('Unexpected end of string expected %d bytes but got %d', [Len, readLen]); 999 | Result := UTF8ToUnicodeString(utf8Str); 1000 | end; 1001 | 1002 | function ReadBytes(const Len: Integer): RawByteString; 1003 | var 1004 | readLen: Integer; 1005 | begin 1006 | // read bytes 1007 | SetLength(Result, Len); 1008 | readLen := Stream.Read(Pointer(Result)^, Len); 1009 | if readLen <> Len then 1010 | raise EReadError.CreateFmt('Unexpected end of binary expected %d bytes but got %d', [Len, readLen]); 1011 | end; 1012 | 1013 | function ReadArray(const Count: Integer): TMsgPackArray; 1014 | var 1015 | i: Integer; 1016 | begin 1017 | Result := TMsgPackArray.Create; 1018 | for i := 0 to Count - 1 do 1019 | begin 1020 | Result.Add(TMsgPackObject.Parse(Stream)); 1021 | end; 1022 | end; 1023 | 1024 | function ReadMap(const Count: Integer): TMsgPackMap; 1025 | var 1026 | i: Integer; 1027 | Key: IMsgPackObject; 1028 | Value: IMsgPackObject; 1029 | begin 1030 | Result := TMsgPackMap.Create; 1031 | for i := 0 to Count - 1 do 1032 | begin 1033 | Key := TMsgPackObject.Parse(Stream); 1034 | if (Key.ObjectType <> mptString) and (Key.ObjectType <> mptBytes) then 1035 | raise EParserError.Create('Expected bytes or string for map key'); 1036 | Value := TMsgPackObject.Parse(Stream); 1037 | Result.InternalPut({$IFDEF STRINGMAPKEYS}Key.AsString{$ELSE}Key{$ENDIF}, Value); 1038 | end; 1039 | end; 1040 | 1041 | var 1042 | prefix: Byte; 1043 | begin 1044 | if FType <> mptNil then 1045 | raise EInvalidOperation.Create('Can''t read to a non nil object'); 1046 | 1047 | prefix := ReadByte(); 1048 | case prefix of 1049 | $C0: // nil 1050 | begin 1051 | FType := mptNil; 1052 | end; 1053 | $C2, $C3: // boolean 1054 | begin 1055 | FType := mptBoolean; 1056 | FVariant.dataBoolean := prefix = $C3; 1057 | end; 1058 | $CA: // float 1059 | begin 1060 | FType := mptFloat; 1061 | FVariant.dataInteger := ReadBEDWord(); 1062 | end; 1063 | $CB: // double 1064 | begin 1065 | FType := mptDouble; 1066 | FVariant.dataInteger := ReadBEQWord(); 1067 | end; 1068 | $CC: // uint8 1069 | begin 1070 | FType := mptInteger; 1071 | FVariant.dataInteger := ReadByte(); 1072 | end; 1073 | $CD: // uint16 1074 | begin 1075 | FType := mptInteger; 1076 | FVariant.dataInteger := Word(ReadBEWord()); 1077 | end; 1078 | $CE: // uint32 1079 | begin 1080 | FType := mptInteger; 1081 | FVariant.dataInteger := ReadBEDWord(); 1082 | end; 1083 | $CF: // uint64 1084 | begin 1085 | FType := mptInteger; 1086 | FVariant.dataInteger := ReadBEQWord(); 1087 | end; 1088 | $D0: // int8 1089 | begin 1090 | FType := mptInteger; 1091 | FVariant.dataInteger := ShortInt(ReadByte()); 1092 | end; 1093 | $D1: // int16 1094 | begin 1095 | FType := mptInteger; 1096 | FVariant.dataInteger := SmallInt(ReadBEWord()); 1097 | end; 1098 | $D2: // int32 1099 | begin 1100 | FType := mptInteger; 1101 | FVariant.dataInteger := Integer(ReadBEDWord()); 1102 | end; 1103 | $D3: // int64 1104 | begin 1105 | FType := mptInteger; 1106 | FVariant.dataInteger := ReadBEQWord(); 1107 | end; 1108 | $D9: // str8 1109 | begin 1110 | FType := mptString; 1111 | FString := ReadString(ReadByte()); 1112 | end; 1113 | $DA: // str16 1114 | begin 1115 | FType := mptString; 1116 | FString := ReadString(ReadBEWord()); 1117 | end; 1118 | $DB: // str32 1119 | begin 1120 | FType := mptString; 1121 | FString := ReadString(ReadBEDWord()); 1122 | end; 1123 | $C4: // bin8 1124 | begin 1125 | FType := mptBytes; 1126 | FBytes := ReadBytes(ReadByte()); 1127 | end; 1128 | $C5: // bin16 1129 | begin 1130 | FType := mptBytes; 1131 | FBytes := ReadBytes(ReadBEWord()); 1132 | end; 1133 | $C6: // bin32 1134 | begin 1135 | FType := mptBytes; 1136 | FBytes := ReadBytes(ReadBEDWord()); 1137 | end; 1138 | $DC: // array16 1139 | begin 1140 | FType := mptArray; 1141 | FVariant.dataArray := ReadArray(ReadBEWord()); 1142 | end; 1143 | $DD: // array32 1144 | begin 1145 | FType := mptArray; 1146 | FVariant.dataArray := ReadArray(ReadBEDWord()); 1147 | end; 1148 | $DE: // map16 1149 | begin 1150 | FType := mptMap; 1151 | FVariant.dataMap := ReadMap(ReadBEWord()); 1152 | end; 1153 | $DF: // map32 1154 | begin 1155 | FType := mptMap; 1156 | FVariant.dataMap := ReadMap(ReadBEDWord()); 1157 | end; 1158 | else 1159 | if prefix and $E0 = $E0 then // fix neg 1160 | begin 1161 | FType := mptInteger; 1162 | FVariant.dataInteger := ShortInt(prefix); 1163 | end 1164 | else if prefix and $A0 = $A0 then // fix str 1165 | begin 1166 | FType := mptString; 1167 | FString := ReadString(prefix and (not $A0)); 1168 | end 1169 | else if prefix and $90 = $90 then // fix array 1170 | begin 1171 | FType := mptArray; 1172 | FVariant.dataArray := ReadArray(prefix and (not $90)); 1173 | end 1174 | else if prefix and $80 = $80 then // fix map 1175 | begin 1176 | FType := mptMap; 1177 | FVariant.dataMap := ReadMap(prefix and (not $80)); 1178 | end 1179 | else if prefix shr 7 = 0 then // fix pos 1180 | begin 1181 | FType := mptInteger; 1182 | FVariant.dataInteger := prefix; 1183 | end 1184 | else 1185 | raise EInvalidOperation.CreateFmt('Unknown prefix \x%.2x', [prefix]); 1186 | end; 1187 | end; 1188 | 1189 | constructor TMsgPackObject.Parse(const Stream: TStream); 1190 | begin 1191 | Read(Stream); 1192 | end; 1193 | 1194 | function TMsgPackObject.Equals(const Other: IMsgPackObject): Boolean; 1195 | 1196 | function ArrayEquals(): Boolean; 1197 | var 1198 | i: Integer; 1199 | otherArray: TMsgPackArray; 1200 | begin 1201 | Result := False; 1202 | if (Other.ObjectType = mptArray) and (Other.AsArray.Count = FVariant.dataArray.Count) then 1203 | begin 1204 | otherArray := Other.AsArray; 1205 | for i := 0 to otherArray.Count - 1 do 1206 | begin 1207 | if not FVariant.dataArray[i].Equals(otherArray[i]) then 1208 | Exit; 1209 | end; 1210 | Result := True; 1211 | end; 1212 | end; 1213 | 1214 | function MapEquals(): Boolean; 1215 | var 1216 | otherMap: TMsgPackMap; 1217 | mapIt: TMsgPackMapIterator; 1218 | otherValue: IMsgPackObject; 1219 | begin 1220 | Result := False; 1221 | if (Other.ObjectType = mptMap) and (Other.AsMap.Count = AsMap.Count) then 1222 | begin 1223 | otherMap := Other.AsMap; 1224 | FVariant.dataMap.IteratorInit(mapIt{%H-}); 1225 | while FVariant.dataMap.IteratorAdvance(mapIt) do 1226 | begin 1227 | otherValue := otherMap.InternalGet(mapIt.Key); 1228 | if (otherValue = nil) or not otherValue.Equals(mapIt.Value) then 1229 | Exit; 1230 | end; 1231 | Result := True; 1232 | end; 1233 | end; 1234 | 1235 | begin 1236 | case FType of 1237 | mptNil: 1238 | Result := (Other.ObjectType = mptNil) and (Other.AsNil = AsNil); 1239 | mptBoolean: 1240 | Result := (Other.ObjectType = mptBoolean) and (Other.AsBoolean = AsBoolean); 1241 | mptInteger: 1242 | Result := (Other.ObjectType = mptInteger) and (Other.AsInteger = AsInteger); 1243 | mptFloat: 1244 | Result := (Other.ObjectType = mptFloat) and (Other.AsFloat = AsFloat); 1245 | mptDouble: 1246 | Result := (Other.ObjectType = mptDouble) and (Other.AsDouble = AsDouble); 1247 | mptBytes: 1248 | Result := ((Other.ObjectType = mptBytes) or (Other.ObjectType = mptString)) and 1249 | (Other.AsBytes = AsBytes); 1250 | mptString: 1251 | Result := ((Other.ObjectType = mptString) or (Other.ObjectType = mptBytes)) and 1252 | (Other.AsString = AsString); 1253 | mptArray: 1254 | Result := ArrayEquals(); 1255 | mptMap: 1256 | Result := MapEquals(); 1257 | else 1258 | begin 1259 | Result := False; 1260 | Assert(False, 'unknown type'); 1261 | end; 1262 | end; 1263 | end; 1264 | 1265 | {$IFNDEF STRINGMAPKEYS} 1266 | function TMsgPackObject.HashCode(): Cardinal; 1267 | var 1268 | i: Integer; 1269 | mapIt: TMsgPackMapIterator; 1270 | begin 1271 | case FType of 1272 | mptNil: 1273 | Result := 0; 1274 | mptBoolean: 1275 | Result := Ord(FVariant.dataBoolean); 1276 | mptInteger: 1277 | Result := Cardinal(FVariant.dataInteger) xor Cardinal(FVariant.dataInteger shr 32); 1278 | mptFloat: 1279 | Result := Cardinal(FVariant.dataInteger); 1280 | mptDouble: 1281 | Result := Cardinal(FVariant.dataInteger) xor Cardinal(FVariant.dataInteger shr 32); 1282 | mptBytes: 1283 | Result := HashBytes(FBytes); 1284 | mptString: 1285 | Result := HashString(FString); 1286 | mptArray: 1287 | begin 1288 | Result := FVariant.dataArray.Count; 1289 | for i := 0 to FVariant.dataArray.Count do 1290 | Result := Result xor FVariant.dataArray[i].HashCode(); 1291 | end; 1292 | mptMap: 1293 | begin 1294 | Result := FVariant.dataMap.Count; 1295 | FVariant.dataMap.IteratorInit(mapIt); 1296 | while FVariant.dataMap.IteratorAdvance(mapIt) do 1297 | Result := Result xor mapIt.Key.HashCode() xor mapIt.Value.HashCode(); 1298 | end; 1299 | else 1300 | begin 1301 | Result := 0; 1302 | Assert(False, 'unknown type'); 1303 | end; 1304 | end; 1305 | end; 1306 | {$ENDIF} 1307 | 1308 | function TMsgPackObject.Clone(): IMsgPackObject; 1309 | var 1310 | i: Integer; 1311 | mapIt: TMsgPackMapIterator; 1312 | begin 1313 | case FType of 1314 | mptNil: 1315 | Result := TMsgPackObject.Create(mptNil); 1316 | mptBoolean: 1317 | Result := TMsgPackObject.Create(FVariant.dataBoolean); 1318 | mptInteger: 1319 | Result := TMsgPackObject.Create(FVariant.dataInteger); 1320 | mptFloat: 1321 | Result := TMsgPackObject.Create(FVariant.dataFloat); 1322 | mptDouble: 1323 | Result := TMsgPackObject.Create(FVariant.dataDouble); 1324 | mptBytes: 1325 | Result := TMsgPackObject.Create(FBytes); 1326 | mptString: 1327 | Result := TMsgPackObject.Create(FString); 1328 | mptArray: 1329 | begin 1330 | Result := TMsgPackObject.Create(mptArray); 1331 | for i := 0 to FVariant.dataArray.Count - 1 do 1332 | Result.AsArray().Add(FVariant.dataArray[i].Clone()) 1333 | end; 1334 | mptMap: 1335 | begin 1336 | Result := TMsgPackObject.Create(mptMap); 1337 | FVariant.dataMap.IteratorInit(mapIt{%H-}); 1338 | while FVariant.dataMap.IteratorAdvance(mapIt) do 1339 | Result.AsMap().InternalPut(mapIt.Key, mapIt.Value.Clone()); 1340 | end; 1341 | end; 1342 | end; 1343 | 1344 | initialization 1345 | 1346 | DeletedBucketValue := TMsgPackObject.Create; 1347 | 1348 | end. 1349 | 1350 | --------------------------------------------------------------------------------