Context Navigation

bgradnetdeserial.pas

Last change on this file was 2, checked in by chronos, 5 years ago
Source code taken from https://svn.zdechov.net/PascalClassLibrary/GraphicTest/ rev 543.
File size: 43.7 KB

Line
1	unit BGRADNetDeserial;
2
3	{$mode objfpc}{$H+}
4
5	interface
6
7	{ This unit allow to read .Net serialized classes with BinaryFormatter of
8	namespace System.Runtime.Serialization.Formatters.Binary.
9
10	Serialization is a process by which objects in memory are saved according
11	to their structure.
12
13	This unit is used by BGRAPaintNet to read Paint.NET images. }
14
15	uses
16	Classes, SysUtils;
17
18	type
19	arrayOfLongword = array of longword;
20
21	TTypeCategory = (ftPrimitiveType = 0, ftString = 1, ftObjectType =
22	2, ftRuntimeType = 3,
23	ftGenericType = 4, ftArrayOfObject = 5, ftArrayOfString = 6,
24	ftArrayOfPrimitiveType = 7);
25
26	TPrimitiveType = (ptNone = 0, ptBoolean = 1, ptByte = 2, ptChar = 3, ptDecimal = 5,
27	ptDouble = 6, ptInt16 = 7, ptInt32 = 8, ptInt64 = 9, ptSByte = 10, ptSingle = 11,
28	ptDateTime = 13, ptUInt16 = 14, ptUInt32 = 15, ptUInt64 = 16, ptString = 18);
29
30	TGenericArrayType = (gatSingleDimension, gatJagged, gatMultidimensional);
31
32	TDotNetDeserialization = class;
33
34	ArrayOfNameValue = array of record
35	Name: string;
36	Value, valueType: string;
37	end;
38
39	TFieldType = record
40	category: TTypeCategory;
41	primitiveType: TPrimitiveType;
42	refAssembly: longword;
43	Name: string;
44	end;
45
46	TSerializedType = record
47	ClassName: string;
48	nbFields: integer;
49	fieldNames: array of string;
50	fieldTypes: array of TFieldType;
51	refAssembly: longword;
52	end;
53
54	TAssemblyReference = record
55	idAssembly: longword;
56	Name: string;
57	end;
58
59	{ TCustomSerializedObject }
60
61	TCustomSerializedObject = class
62	protected
63	FContainer: TDotNetDeserialization;
64	function GetTypeAsString: string; virtual; abstract;
65	function GetFieldAsString(Index: longword): string; overload; virtual; abstract;
66	function GetFieldAsString(Name: string): string; overload;
67	function GetFieldCount: longword; virtual; abstract;
68	function GetFieldName(Index: longword): string; virtual; abstract;
69	function GetFieldTypeAsString(Index: longword): string; virtual; abstract;
70	function IsReferenceType(index: longword): boolean; virtual; abstract;
71	public
72	idObject: longword;
73	refCount: integer;
74	inToString: boolean;
75	constructor Create(container: TDotNetDeserialization); virtual;
76	property FieldCount: longword read GetFieldCount;
77	property FieldName[Index: longword]:string read GetFieldName;
78	property FieldAsString[Index: longword]: string read GetFieldAsString;
79	property FieldByNameAsString[Name: string]: string read GetFieldAsString;
80	property FieldTypeAsString[Index: longword]: string read GetFieldTypeAsString;
81	property TypeAsString: string read GetTypeAsString;
82	function GetFieldIndex(Name: string): integer;
83	end;
84
85	{ TSerializedClass }
86
87	TSerializedClass = class(TCustomSerializedObject)
88	protected
89	function GetFieldAsString(Index: longword): string; override;
90	function GetFieldCount: longword; override;
91	function GetFieldName(Index: longword): string; override;
92	function GetFieldTypeAsString(Index: longword): string; override;
93	function IsReferenceType(index: longword): boolean; override;
94	function GetTypeAsString: string; override;
95	public
96	numType: integer;
97	fields: ArrayOfNameValue;
98	end;
99
100	{ TSerializedArray }
101
102	TSerializedArray = class(TCustomSerializedObject)
103	private
104	data: pointer;
105	FItemSize: longword;
106	function GetItemPtr(Index: longword): pointer;
107	procedure InitData;
108	protected
109	FArrayType: TGenericArrayType;
110	function GetFieldAsString(Index: longword): string; override;
111	function GetFieldCount: longword; override;
112	function GetFieldName(Index: longword): string; override;
113	function GetFieldTypeAsString(Index: longword): string; override;
114	function IsReferenceType(index: longword): boolean; override;
115	function GetTypeAsString: string; override;
116	public
117	dimensions: array of longword;
118	itemType: TFieldType;
119	nbItems: longword;
120	constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword); overload;
121	constructor Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType; ADimensions: arrayOfLongword); overload;
122	destructor Destroy; override;
123	property ItemPtr[Index:longword]: pointer read GetItemPtr;
124	property ItemSize: longword read FItemSize;
125	end;
126
127	{ TSerializedValue }
128
129	TSerializedValue = class(TSerializedArray)
130	protected
131	function GetIsReferenceType: boolean;
132	function GetValueAsString: string;
133	function GetTypeAsString: string; override;
134	public
135	constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType); overload;
136	property ValueAsString: string read GetValueAsString;
137	property IsReferenceType: boolean read GetIsReferenceType;
138	end;
139
140	{ TDotNetDeserialization }
141	TDotNetDeserialization = class
142	objectTypes: array of TSerializedType;
143	assemblies: array of TAssemblyReference;
144	objects: array of TCustomSerializedObject;
145
146	function FindClass(typeName: string): TSerializedClass;
147	function FindObject(typeName: string): TCustomSerializedObject;
148	function GetSimpleField(obj: TCustomSerializedObject; Name: string): string;
149	function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject; overload;
150	function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject; overload;
151	function GetObject(id: string): TCustomSerializedObject; overload;
152	function GetObject(id: longword): TCustomSerializedObject; overload;
153	function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean;
154	function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string;
155	procedure LoadFromStream(Stream: TStream);
156	procedure LoadFromFile(filename: string);
157	procedure LoadFromFileUTF8(filenameUTF8: string);
158	function ToString: string; override;
159	constructor Create;
160	destructor Destroy; override;
161	function GetTypeOfClassObject(idObject: longword): integer;
162	private
163	EndOfStream: boolean;
164	ArrayFillerCount: Longword;
165	currentAutoObjectValue: longword;
166	function nextAutoObjectId: longword;
167	function LoadNextFromStream(Stream: TStream): longword;
168	function LoadStringFromStream(Stream: TStream): string;
169	function LoadDotNetCharFromStream(Stream: TStream): string;
170	function LoadTypeFromStream(Stream: TStream; IsRuntimeType: boolean): integer;
171	function LoadValuesFromStream(Stream: TStream; numType: integer): ArrayOfNameValue;
172	function LoadValueFromStream(Stream: TStream; const fieldType: TFieldType): string;
173	function LoadFieldType(Stream: TStream; category: TTypeCategory): TFieldType;
174	end;
175
176	function WinReadByte(stream: TStream): byte;
177	function WinReadWord(Stream: TStream): word;
178	function WinReadSmallInt(Stream: TStream): smallint;
179	function WinReadLongint(Stream: TStream): longint;
180	function WinReadLongword(Stream: TStream): longword;
181	function WinReadInt64(Stream: TStream): int64;
182	function WinReadQWord(Stream: TStream): QWord;
183
184	implementation
185
186	uses BGRAUTF8;
187
188	const
189	//block types
190	btRefTypeObject = 1;
191	btRuntimeObject = 4;
192	btExternalObject = 5;
193	btString = 6;
194	btGenericArray = 7;
195	btBoxedPrimitiveTypeValue = 8;
196	btObjectReference = 9;
197	btNullValue = 10;
198	btEndOfStream = 11;
199	btAssembly = 12;
200	btArrayFiller8b = 13;
201	btArrayFiller32b = 14;
202	btArrayOfPrimitiveType = 15;
203	btArrayOfObject = 16;
204	btArrayOfString = 17;
205	btMethodCall = 21;
206	btMethodResponse = 22;
207
208	idArrayFiller = $80000000;
209
210	{$hints off}
211
212	function WinReadByte(stream: TStream): byte;
213	begin
214	stream.Read(Result, sizeof(Result));
215	end;
216
217	function WinReadWord(Stream: TStream): word;
218	begin
219	stream.Read(Result, sizeof(Result));
220	Result := LEtoN(Result);
221	end;
222
223	function WinReadSmallInt(Stream: TStream): smallint;
224	begin
225	stream.Read(Result, sizeof(Result));
226	Result := LEtoN(Result);
227	end;
228
229	function WinReadLongint(Stream: TStream): longint;
230	begin
231	stream.Read(Result, sizeof(Result));
232	Result := LEtoN(Result);
233	end;
234
235	function WinReadLongword(Stream: TStream): longword;
236	begin
237	stream.Read(Result, sizeof(Result));
238	Result := LEtoN(Result);
239	end;
240
241	function WinReadInt64(Stream: TStream): int64;
242	begin
243	stream.Read(Result, sizeof(Result));
244	Result := LEtoN(Result);
245	end;
246
247	function WinReadQWord(Stream: TStream): QWord;
248	begin
249	stream.Read(Result, sizeof(Result));
250	Result := LEtoN(Result);
251	end;
252
253	{$hints on}
254
255	function GetFieldTypeSize(const fieldType: TFieldType): longword;
256	begin
257	case fieldType.category of
258	ftPrimitiveType:
259	case fieldType.primitiveType of
260	ptBoolean, ptByte,ptSByte: result := 1;
261	ptChar,ptString, ptDecimal: Result := sizeof(string);
262	ptSingle: result := sizeof(single);
263	ptDouble: result := sizeof(double);
264	ptInt16,ptUInt16: result := 2;
265	ptInt32,ptUInt32: result := 4;
266	ptInt64,ptUInt64,ptDateTime: result := 8;
267	else
268	raise Exception.Create('Unknown primitive type (' + IntToStr(
269	byte(fieldType.primitiveType)) + ')');
270	end;
271	ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
272	ftArrayOfString, ftArrayOfPrimitiveType: result := 4;
273	else
274	raise Exception.Create('Unknown field type (' + IntToStr(
275	byte(fieldType.category)) + ')');
276	end;
277	end;
278
279	function IsDotNetTypeStoredAsString(const fieldType: TFieldType): boolean;
280	begin
281	result := (fieldType.category = ftPrimitiveType) and
282	(fieldType.primitiveType in [ptChar,ptString,ptDecimal]);
283	end;
284
285	function DotNetValueToString(var value; const fieldType: TFieldType): string;
286	var
287	tempByte: byte;
288	value2bytes: record
289	case byte of
290	2: (tempWord: word);
291	3: (tempInt16: smallint);
292	end;
293	value4bytes: record
294	case byte of
295	1: (tempSingle: single);
296	2: (tempLongWord: longword);
297	3: (tempLongInt: longint);
298	end;
299	value8bytes: record
300	case byte of
301	1: (tempDouble: double);
302	2: (tempInt64: Int64);
303	2: (tempUInt64: QWord);
304	end;
305	tempIdObject: longword;
306
307	begin
308	if IsDotNetTypeStoredAsString(fieldType) then
309	begin
310	Result := pstring(@value)^;
311	exit;
312	end;
313	case fieldType.category of
314	ftPrimitiveType: case fieldType.primitiveType of
315	ptBoolean:
316	begin
317	{$hints off}
318	move(value,tempByte,sizeof(tempByte));
319	{$hints on}
320	if tempByte = 0 then
321	Result := 'False'
322	else
323	if tempByte = 1 then
324	Result := 'True'
325	else
326	raise Exception.Create('Invalid boolean value (' +
327	IntToStr(tempByte) + ')');
328	end;
329	ptByte: Result := inttostr(pbyte(@value)^);
330	ptSByte: Result := inttostr(pshortint(@value)^);
331	ptInt16,ptUInt16:
332	begin
333	{$hints off}
334	move(value, value2bytes.tempWord,sizeof(word));
335	{$hints on}
336	value2bytes.tempWord := LEtoN(value2bytes.tempWord);
337	if fieldType.primitiveType = ptInt16 then
338	Result := IntToStr(value2bytes.tempInt16)
339	else
340	Result := IntToStr(value2bytes.tempWord);
341	end;
342	ptInt32,ptUInt32,ptSingle:
343	begin
344	{$hints off}
345	move(value, value4bytes.tempLongWord,sizeof(longword));
346	{$hints on}
347	value4bytes.tempLongWord := LEtoN(value4bytes.tempLongWord);
348	if fieldType.primitiveType = ptInt32 then
349	Result := IntToStr(value4bytes.tempLongInt)
350	else if fieldType.primitiveType = ptUInt32 then
351	Result := IntToStr(value4bytes.tempLongWord)
352	else
353	result := FloatToStr(value4bytes.tempSingle);
354	end;
355
356	ptInt64,ptUInt64,ptDouble,ptDateTime:
357	begin
358	{$hints off}
359	move(value, value8bytes.tempUInt64,8);
360	{$hints on}
361	value8bytes.tempUInt64 := LEtoN(value8bytes.tempUInt64);
362	if fieldType.primitiveType = ptInt64 then
363	Result := IntToStr(value8bytes.tempInt64)
364	else if fieldType.primitiveType = ptUInt64 then
365	Result := IntToStr(value8bytes.tempUInt64)
366	else if fieldType.primitiveType = ptDouble then
367	result := FloatToStr(value8bytes.tempDouble)
368	else
369	Result := DateTimeToStr(
370	(value8bytes.tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
371	end;
372	else
373	raise Exception.Create('Unknown primitive type (' + IntToStr(
374	byte(fieldType.primitiveType)) + ')');
375	end;
376	ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
377	ftArrayOfString, ftArrayOfPrimitiveType:
378	begin
379	{$hints off}
380	move(value,tempIdObject,sizeof(tempIdObject));
381	{$hints on}
382	result := '#' + IntToStr(tempIdObject);
383	end;
384	else
385	raise Exception.Create('Unknown field type (' + IntToStr(
386	byte(fieldType.category)) + ')');
387	end;
388	end;
389
390	function PrimitiveTypeName(pt: TPrimitiveType): string;
391	begin
392	case pt of
393	ptBoolean: Result := 'Boolean';
394	ptByte: Result := 'Byte';
395	ptChar: Result := 'Char';
396	ptDecimal: Result := 'Decimal';
397	ptDouble: Result := 'Double';
398	ptInt16: Result := 'Int16';
399	ptInt32: Result := 'Int32';
400	ptInt64: Result := 'Int64';
401	ptSByte: Result := 'SByte';
402	ptSingle: Result := 'Single';
403	ptDateTime: Result := 'DateTime';
404	ptUInt16: Result := 'UInt16';
405	ptUInt32: Result := 'UInt32';
406	ptUInt64: Result := 'UInt64';
407	ptString: Result := 'String';
408	else
409	raise Exception.Create('Unknown primitive type (' + IntToStr(integer(pt)) + ')');
410	end;
411	end;
412
413	Function DotNetTypeToString(ft: TFieldType): string;
414	begin
415	if ft.category = ftPrimitiveType then
416	result := PrimitiveTypeName(ft.primitiveType)
417	else
418	case ft.category of
419	ftString: result := 'String';
420	ftObjectType: result := 'Object';
421	ftRuntimeType: result := 'RuntimeType';
422	ftGenericType: result := 'GenericType';
423	ftArrayOfObject: result := 'Object[]';
424	ftArrayOfString: result := 'String[]';
425	ftArrayOfPrimitiveType: result := 'PrimitiveType[]';
426	else
427	raise Exception.Create('Unknown field type (' + IntToStr(
428	byte(ft.category)) + ')');
429	end;
430	end;
431
432	{ TCustomSerializedObject }
433
434	function TCustomSerializedObject.GetFieldAsString(Name: string): string;
435	begin
436	result := GetFieldAsString(GetFieldIndex(Name));
437	end;
438
439	constructor TCustomSerializedObject.Create(container: TDotNetDeserialization);
440	begin
441	FContainer := container;
442	refCount := 0;
443	end;
444
445	function TCustomSerializedObject.GetFieldIndex(Name: string): integer;
446	var
447	i: integer;
448	fn: string;
449	begin
450	if FieldCount = 0 then
451	begin
452	result := -1;
453	exit;
454	end;
455	//case sensitive
456	for i := 0 to FieldCount-1 do
457	if FieldName[i] = Name then
458	begin
459	Result := i;
460	exit;
461	end;
462	//case insensitive
463	for i := 0 to FieldCount-1 do
464	if compareText(FieldName[i], Name) = 0 then
465	begin
466	Result := i;
467	exit;
468	end;
469	//case sensitive inner member
470	for i := 0 to FieldCount-1 do
471	begin
472	fn := FieldName[i];
473	if (length(Name) < length(fn)) and
474	(copy(fn, length(fn) - length(Name),
475	length(Name) + 1) = '+' + Name) then
476	begin
477	Result := i;
478	exit;
479	end;
480	end;
481	//case insensitive inner member
482	for i := 0 to FieldCount-1 do
483	begin
484	fn := FieldName[i];
485	if (length(Name) < length(fn)) and
486	(compareText(copy(fn, length(fn) -
487	length(Name), length(Name) + 1), '+' + Name) = 0) then
488	begin
489	Result := i;
490	exit;
491	end;
492	end;
493	Result := -1;
494	end;
495
496	{ TSerializedClass }
497
498	function TSerializedClass.GetFieldAsString(Index: longword): string;
499	begin
500	result := fields[Index].Value;
501	end;
502
503	function TSerializedClass.GetFieldCount: longword;
504	begin
505	Result:= length(fields);
506	end;
507
508	function TSerializedClass.GetFieldName(Index: longword): string;
509	begin
510	result := fields[Index].Name;
511	end;
512
513	function TSerializedClass.GetFieldTypeAsString(Index: longword): string;
514	begin
515	result := fields[Index].valueType;
516	end;
517
518	function TSerializedClass.IsReferenceType(index: longword): boolean;
519	begin
520	Result:= FContainer.objectTypes[numType].fieldTypes[index].category <> ftPrimitiveType;
521	end;
522
523	function TSerializedClass.GetTypeAsString: string;
524	begin
525	Result:= FContainer.objectTypes[numType].ClassName;
526	end;
527
528	{ TSerializedArray }
529
530	procedure TSerializedArray.InitData;
531	begin
532	FItemSize := GetFieldTypeSize(itemType);
533	getmem(data, itemSize*nbItems);
534	fillchar(data^, itemSize*nbItems, 0);
535	end;
536
537	function TSerializedArray.GetItemPtr(Index: longword): pointer;
538	begin
539	if index >= nbItems then
540	raise exception.Create('Index out of bounds');
541	result := pointer(pbyte(data)+Index*itemsize);
542	end;
543
544	function TSerializedArray.GetFieldAsString(Index: longword): string;
545	begin
546	if data = nil then
547	result := ''
548	else
549	result := DotNetValueToString(ItemPtr[index]^, itemType);
550	end;
551
552	function TSerializedArray.GetFieldCount: longword;
553	begin
554	Result:= nbItems;
555	end;
556
557	function TSerializedArray.GetFieldName(Index: longword): string;
558	var
559	r: longword;
560	begin
561	result := '[';
562	for r := 1 to length(dimensions) do
563	begin
564	if r <> 1 then result+=',';
565	result += inttostr(index mod dimensions[r-1]);
566	index := index div dimensions[r-1];
567	end;
568	result += ']';
569	end;
570
571	{$hints off}
572	function TSerializedArray.GetFieldTypeAsString(Index: longword): string;
573	begin
574	Result:= DotNetTypeToString(itemType);
575	end;
576	{$hints on}
577
578	{$hints off}
579	function TSerializedArray.IsReferenceType(index: longword): boolean;
580	begin
581	Result:= itemType.category <> ftPrimitiveType;
582	end;
583	{$hints on}
584
585	function TSerializedArray.GetTypeAsString: string;
586	var
587	i: Integer;
588	begin
589	Result:= DotNetTypeToString(itemType)+'[';
590	for i := 2 to length(dimensions) do
591	result += ',';
592	result += ']';
593	end;
594
595	constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword);
596	begin
597	inherited Create(AContainer);
598	setlength(dimensions,1);
599	dimensions[0] := ALength;
600	nbItems := ALength;
601	FArrayType := gatSingleDimension;
602	itemType := AItemType;
603	InitData;
604	end;
605
606	constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType;
607	ADimensions: arrayOfLongword);
608	var n: longword;
609	begin
610	inherited Create(AContainer);
611	setlength(dimensions, length(ADimensions));
612	nbItems := 1;
613	if length(ADimensions) <> 0 then
614	for n := 0 to length(ADimensions)-1 do
615	begin
616	dimensions[n] := ADimensions[n];
617	nbItems *= ADimensions[n];
618	end;
619	FArrayType := AArrayType;
620	itemType := AItemType;
621	InitData;
622	end;
623
624	destructor TSerializedArray.Destroy;
625	var ps: PString;
626	n: longword;
627	begin
628	if IsDotNetTypeStoredAsString(itemType) and (nbItems <> 0) then
629	begin
630	ps := PString(data);
631	for n := 1 to nbItems do
632	begin
633	ps^ := '';
634	inc(ps);
635	end;
636	end;
637	freemem(data);
638	inherited Destroy;
639	end;
640
641	{ TSerializedValue }
642
643	function TSerializedValue.GetIsReferenceType: boolean;
644	begin
645	result := inherited IsReferenceType(0);
646	end;
647
648	function TSerializedValue.GetValueAsString: string;
649	begin
650	result := GetFieldAsString(0);
651	end;
652
653	function TSerializedValue.GetTypeAsString: string;
654	begin
655	Result:= GetFieldTypeAsString(0);
656	end;
657
658	constructor TSerializedValue.Create(AContainer: TDotNetDeserialization;
659	AItemType: TFieldType);
660	begin
661	inherited Create(AContainer,AItemType,1);
662	end;
663
664	{ TDotNetDeserialization }
665
666	function TDotNetDeserialization.FindClass(typeName: string): TSerializedClass;
667	var obj: TCustomSerializedObject;
668	begin
669	obj := FindObject(typeName);
670	if obj is TSerializedClass then
671	result := obj as TSerializedClass
672	else
673	raise exception.Create('FindClass: found object is not a class');
674	end;
675
676	function TDotNetDeserialization.FindObject(typeName: string): TCustomSerializedObject;
677	var
678	i: integer;
679	comparedType: string;
680	begin
681	for i := 0 to high(objects) do
682	begin
683	comparedType := objects[i].TypeAsString;
684	if (comparedType = typeName) or
685	( (length(typeName) < length(comparedType) ) and
686	(copy(comparedType, length(comparedType) - length(typeName),
687	length(typeName) + 1) = '.' + typeName) ) then
688	begin
689	Result := objects[i];
690	exit;
691	end;
692	end;
693	Result := nil;
694	end;
695
696	function TDotNetDeserialization.GetSimpleField(obj: TCustomSerializedObject;
697	Name: string): string;
698	var
699	i,idxSlash: integer;
700	tempSub: TCustomSerializedObject;
701	begin
702	i := obj.GetFieldIndex(Name);
703	if i = -1 then
704	begin
705	idxSlash := pos('\',name);
706	if idxSlash <> 0 then
707	begin
708	tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
709	if tempSub <> nil then
710	begin
711	result := GetSimpleField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
712	exit;
713	end;
714	end;
715	Result := ''
716	end
717	else
718	begin
719	if IsBoxedValue(obj, i) then
720	Result := GetBoxedValue(obj, i)
721	else
722	Result := obj.FieldAsString[i];
723	end;
724	end;
725
726	function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
727	Name: string): TCustomSerializedObject;
728	var
729	i: integer;
730	idxSlash: LongInt;
731	tempSub: TCustomSerializedObject;
732	begin
733	i := obj.GetFieldIndex(Name);
734	if i = -1 then
735	begin
736	idxSlash := pos('\',name);
737	if idxSlash <> 0 then
738	begin
739	tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
740	if tempSub <> nil then
741	begin
742	result := GetObjectField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
743	exit;
744	end;
745	end;
746	Result := nil
747	end
748	else
749	begin
750	if not obj.IsReferenceType(i) then
751	raise Exception.Create('GetObjectField: Not a reference type');
752	Result := GetObject(obj.FieldAsString[i]);
753	end;
754	end;
755
756	function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
757	index: integer): TCustomSerializedObject;
758	begin
759	if not obj.IsReferenceType(index) then
760	raise Exception.Create('GetObjectField: Not a reference type');
761	Result := GetObject(obj.FieldAsString[index]);
762	end;
763
764	function TDotNetDeserialization.GetObject(id: string): TCustomSerializedObject;
765	var
766	idObj: longword;
767	begin
768	if copy(id, 1, 1) = '#' then
769	Delete(id, 1, 1);
770	idObj := StrToInt64(id);
771	Result := GetObject(idObj);
772	end;
773
774	function TDotNetDeserialization.GetObject(id: longword): TCustomSerializedObject;
775	var
776	i: integer;
777	begin
778	for i := 0 to high(objects) do
779	if objects[i].idObject = id then
780	begin
781	Result := objects[i];
782	exit;
783	end;
784	Result := nil;
785	end;
786
787	function TDotNetDeserialization.IsBoxedValue(obj: TCustomSerializedObject;
788	index: integer): boolean;
789	var
790	subObj: TCustomSerializedObject;
791	begin
792	if not obj.IsReferenceType(index) then
793	begin
794	Result := False;
795	exit;
796	end;
797	subObj := GetObject(obj.FieldAsString[index]);
798	if subObj = nil then //suppose Nothing is a boxed value
799	begin
800	Result := True;
801	exit;
802	end;
803	Result := subObj is TSerializedValue;
804	end;
805
806	function TDotNetDeserialization.GetBoxedValue(obj: TCustomSerializedObject;
807	index: integer): string;
808	var
809	subObj: TCustomSerializedObject;
810	begin
811	if not obj.IsReferenceType(index) then
812	raise Exception.Create('GetBoxedValue: Not a reference type');
813	subObj := GetObject(obj.FieldAsString[index]);
814	if subObj = nil then
815	begin
816	Result := ''; //empty value
817	exit;
818	end;
819	if (subObj is TSerializedValue) and not (subObj as TSerializedValue).IsReferenceType then
820	Result := (subObj as TSerializedValue).ValueAsString
821	else
822	raise Exception.Create('GetBoxedValue: Not a primitive type');
823	end;
824
825	procedure TDotNetDeserialization.LoadFromStream(Stream: TStream);
826	var
827	header: packed record
828	blockId: byte;
829	value1, value2, value3, value4: longint;
830	end;
831	curStreamPosition, prevStreamPosition: int64;
832	begin
833	{$hints off}
834	if Stream.Read(header, sizeof(header)) <> sizeof(header) then
835	raise Exception.Create('Invalid header size');
836	if (header.blockId <> 0) or (header.value1 <> 1) or (header.value2 <> -1) or
837	(header.value3 <> 1) or (header.value4 <> 0) then
838	raise Exception.Create('Invalid header format');
839	{$hints on}
840
841	EndOfStream := False;
842	curStreamPosition := Stream.Position;
843	try
844	while (Stream.Position < Stream.Size) and not EndOfStream do
845	begin
846	prevStreamPosition := curStreamPosition;
847	curStreamPosition := Stream.Position;
848	LoadNextFromStream(Stream);
849	end;
850	except
851	on ex: Exception do
852	raise Exception.Create('Error while loading serialized data at position ' +
853	IntToStr(stream.Position) + ' (block starting at ' +
854	IntToStr(curStreamPosition) + ', previous block at ' +
855	IntToStr(prevStreamPosition) + '). ' + ex.message);
856	end;
857	end;
858
859	procedure TDotNetDeserialization.LoadFromFile(filename: string);
860	var
861	stream: TFileStream;
862	begin
863	stream := TFileStream.Create(filename, fmOpenRead);
864	try
865	LoadFromStream(stream);
866	finally
867	stream.Free;
868	end;
869	end;
870
871	procedure TDotNetDeserialization.LoadFromFileUTF8(filenameUTF8: string);
872	var
873	stream: TFileStreamUTF8;
874	begin
875	stream := TFileStreamUTF8.Create(filenameUTF8, fmOpenRead);
876	try
877	LoadFromStream(stream);
878	finally
879	stream.Free;
880	end;
881	end;
882
883	function TDotNetDeserialization.ToString: string;
884
885	function ObjectToString(num: integer; expectedType: string;
886	tab: string; main: boolean): string;
887	var
888	j, k: integer;
889	subId: longword;
890	subNum: integer;
891	objType, subExpectedType: string;
892	fieldTypeStr: string;
893	begin
894	Result := '';
895	if (num < 0) or (num > high(objects)) then
896	raise Exception.Create('Index out of bounds');
897	with objects[num] do //here array is not changed so it won't move
898	begin
899	if inToString then
900	begin
901	if main then
902	Result := ''
903	else
904	Result := '#' + IntToStr(idObject) + LineEnding;
905	exit;
906	end;
907	inToString := True;
908	objType := TypeAsString;
909	if main then
910	begin
911	Result += tab + 'Object';
912	Result += ' #' + IntToStr(idObject);
913	if (objType = '') or (objType = expectedType) then
914	Result += ' = '
915	else
916	Result += ' As ' + objType + ' = ';
917	end
918	else
919	begin
920	if (objType = '') or (objType = expectedType) then
921	Result := ''
922	else
923	Result := '(' + objType + ') ';
924	if (idObject < idArrayFiller) and (refCount > 0) then
925	Result += '#' + IntToStr(idObject) + ' = ';
926	end;
927	if (length(objType) > 2) and (copy(objType, length(objType) - 1, 2) = '[]') then
928	subExpectedType := copy(objType, 1, length(objType) - 2)
929	else
930	subExpectedType := '';
931
932	if not main and (objects[num] is TSerializedValue) then
933	begin
934	Result += (objects[num] as TSerializedValue).ValueAsString + LineEnding;
935	end
936	else
937	if (FieldCount = 0) then
938	begin
939	Result += '{}' + LineEnding;
940	end
941	else
942	begin
943	Result += '{' + LineEnding;
944	for j := 0 to FieldCount-1 do
945	begin
946	Result += tab + ' ' + FieldName[j];
947	fieldTypeStr := FieldTypeAsString[j];
948	if (fieldTypeStr <> '') and (fieldTypeStr <> subExpectedType) and
949	not ((subExpectedType = '') and ((fieldTypeStr = 'Int32') or
950	(fieldTypeStr = 'Boolean') or (fieldTypeStr = 'Double'))) then
951	Result += ' As ' + fieldTypeStr;
952	Result += ' = ';
953	if not IsReferenceType(j) then
954	Result += FieldAsString[j] + lineending
955	else
956	begin
957	try
958	subId := StrToInt64(copy(fieldAsString[j], 2, length(fieldAsString[j]) - 1));
959	if subId = 0 then result += 'null'+LineEnding else
960	begin
961	begin
962	subNum := -1;
963	for k := 0 to high(objects) do
964	if (objects[k].idObject = subId) then
965	begin
966	subNum := k;
967	break;
968	end;
969	end;
970	if subNum = -1 then
971	Result += '(Not found) #' + IntToStr(subId)+LineEnding
972	else
973	Result += objectToString(subNum, fieldTypeStr, tab + ' ', False);
974	end;
975	except
976	result += '!' + fieldAsString[j]+'!' +LineEnding
977	end;
978	end;
979	end;
980	Result += tab + '}' + LineEnding;
981	if main then
982	Result += LineEnding;
983	end;
984	end;
985	end;
986
987	var
988	i: integer;
989	begin
990	Result := '';
991	for i := 0 to high(assemblies) do
992	Result += 'Imports ' + assemblies[i].Name + LineEnding;
993	Result += lineEnding;
994	for i := 0 to high(objects) do
995	objects[i].inToString := False;
996	for i := 0 to high(objects) do
997	Result += ObjectToString(i, 'Object', '', True);
998	end;
999
1000	constructor TDotNetDeserialization.Create;
1001	begin
1002	currentAutoObjectValue := idArrayFiller + 1;
1003	end;
1004
1005	destructor TDotNetDeserialization.Destroy;
1006	var
1007	i: Integer;
1008	begin
1009	for i := 0 to high(objects) do
1010	objects[i].Free;
1011	inherited Destroy;
1012	end;
1013
1014	function TDotNetDeserialization.GetTypeOfClassObject(idObject: longword
1015	): integer;
1016	var
1017	i: Integer;
1018	begin
1019	for i := 0 to high(objects) do
1020	if objects[i].idObject = idObject then
1021	begin
1022	if objects[i] is TSerializedClass then
1023	begin
1024	result := (objects[i] as TSerializedClass).numType;
1025	exit;
1026	end
1027	else
1028	raise exception.Create('GetTypeOfClassObject: Specified object is not of class type');
1029	end;
1030	raise exception.Create('GetTypeOfClassObject: Object not found');
1031	end;
1032
1033	function TDotNetDeserialization.nextAutoObjectId: longword;
1034	begin
1035	Inc(currentAutoObjectValue);
1036	Result := currentAutoObjectValue;
1037	end;
1038
1039	function TDotNetDeserialization.LoadNextFromStream(Stream: TStream): longword;
1040	var
1041	blockType: byte;
1042	idRefObject, tempIdObject: longword;
1043	tempType: TFieldType;
1044	arrayCount, arrayIndex,FillZeroCount : longword;
1045	tempAnyObj: TCustomSerializedObject;
1046	newClassObj: TSerializedClass;
1047	newValueObj: TSerializedValue;
1048	newArrayObj: TSerializedArray;
1049	genericArrayType: TGenericArrayType;
1050	genericArrayRank: longword;
1051	genericArrayDims: array of longword;
1052	genericArrayItemType: TFieldType;
1053
1054	function GetArrayCellNumber(index: longword): string;
1055	var r: longword;
1056	begin
1057	result := '';
1058	for r := 1 to genericArrayRank do
1059	begin
1060	if r <> 1 then result+=',';
1061	result += inttostr(index mod genericArrayDims[r-1]);
1062	index := index div genericArrayDims[r-1];
1063	end;
1064	end;
1065
1066	begin
1067	Result := 0; //idObject or zero
1068	blockType := WinReadByte(Stream);
1069	case blockType of
1070
1071	btAssembly:
1072	begin
1073	setlength(assemblies, length(assemblies) + 1);
1074	with assemblies[high(assemblies)] do
1075	begin
1076	idAssembly := WinReadLongword(Stream);
1077	Name := LoadStringFromStream(Stream);
1078	end;
1079	end;
1080
1081	btRuntimeObject, btExternalObject:
1082	begin
1083	newClassObj := TSerializedClass.Create(self);
1084	setlength(objects, length(objects) + 1);
1085	objects[high(objects)] := newClassObj;
1086	with newClassObj do
1087	begin
1088	idObject := WinReadLongword(Stream);
1089	Result := idObject;
1090	numType := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
1091	fields := LoadValuesFromStream(Stream, numType);
1092	end;
1093	end;
1094
1095	btRefTypeObject:
1096	begin
1097	newClassObj := TSerializedClass.Create(self);
1098	setlength(objects, length(objects) + 1);
1099	objects[high(objects)] := newClassObj;
1100	with newClassObj do
1101	begin
1102	idObject := WinReadLongword(Stream);
1103	Result := idObject;
1104	idRefObject := WinReadLongword(Stream);
1105	numType := GetTypeOfClassObject(idRefObject);
1106	fields := LoadValuesFromStream(Stream, numType);
1107	end;
1108	end;
1109
1110	btString:
1111	begin
1112	tempType.primitiveType := ptString;
1113	tempType.category := ftPrimitiveType;
1114	tempType.Name := PrimitiveTypeName(ptString);
1115	tempType.refAssembly := 0;
1116
1117	newValueObj := TSerializedValue.Create(self,tempType);
1118	setlength(objects, length(objects) + 1);
1119	objects[high(objects)] := newValueObj;
1120	with newValueObj do
1121	begin
1122	idObject := WinReadLongword(Stream);
1123	Result := idObject;
1124	pstring(data)^ := LoadStringFromStream(Stream);
1125	end;
1126	end;
1127
1128	btBoxedPrimitiveTypeValue:
1129	begin
1130	try
1131	tempType.category := ftPrimitiveType;
1132	tempType.refAssembly := 0;
1133	tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
1134	tempType.Name := PrimitiveTypeName(tempType.primitiveType);
1135
1136	newValueObj := TSerializedValue.Create(self,tempType);
1137	setlength(objects, length(objects) + 1);
1138	objects[high(objects)] := newValueObj;
1139
1140	with newValueObj do
1141	begin
1142	idObject := nextAutoObjectId;
1143	Result := idObject;
1144
1145	if IsDotNetTypeStoredAsString(tempType) then
1146	pstring(data)^ := LoadValueFromStream(Stream, tempType)
1147	else
1148	Stream.Read(data^, itemSize);
1149	end;
1150	except
1151	on ex: Exception do
1152	raise Exception.Create('Error while reading boxed primitive values. ' +
1153	ex.Message);
1154	end;
1155	end;
1156
1157	btObjectReference:
1158	begin
1159	result := WinReadLongword(Stream);
1160	tempAnyObj := GetObject(Result);
1161	if tempAnyObj <> nil then
1162	Inc(tempAnyObj.refCount);
1163	end;
1164
1165	btNullValue: Result := 0;
1166
1167	btArrayOfPrimitiveType:
1168	begin
1169	try
1170	result := WinReadLongword(Stream);
1171	arrayCount := WinReadLongword(Stream);
1172
1173	tempType.category := ftPrimitiveType;
1174	tempType.refAssembly := 0;
1175	tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
1176	tempType.Name := PrimitiveTypeName(tempType.primitiveType);
1177
1178	newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
1179	setlength(objects, length(objects) + 1);
1180	objects[high(objects)] := newArrayObj;
1181	with newArrayObj do
1182	begin
1183	idObject := result;
1184
1185	if arrayCount <> 0 then
1186	begin
1187	if IsDotNetTypeStoredAsString(tempType) then
1188	begin
1189	for arrayIndex := 0 to arrayCount - 1 do
1190	pstring(ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream, tempType);
1191	end else
1192	begin
1193	for arrayIndex := 0 to arrayCount - 1 do
1194	stream.Read(ItemPtr[arrayIndex]^, itemSize);
1195	end;
1196	end;
1197	end;
1198	except
1199	on ex: Exception do
1200	raise Exception.Create('Error while reading array of primitive values. ' +
1201	ex.Message);
1202	end;
1203	end;
1204
1205	btArrayOfObject,btArrayOfString:
1206	begin
1207	try
1208	result := WinReadLongword(Stream);
1209	arrayCount := WinReadLongword(Stream);
1210
1211	if blockType = btArrayOfObject then
1212	tempType.category := ftObjectType
1213	else
1214	tempType.category := ftString;
1215
1216	tempType.refAssembly := 0;
1217	tempType.primitiveType := ptNone;
1218	tempType.Name := DotNetTypeToString(tempType);
1219
1220	newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
1221	setlength(objects, length(objects) + 1);
1222	objects[high(objects)] := newArrayObj;
1223
1224	with newArrayObj do
1225	begin
1226	idObject:= result;
1227	FillZeroCount := 0;
1228	if arrayCount <> 0 then
1229	for arrayIndex := 0 to arrayCount - 1 do
1230	begin
1231	if FillZeroCount > 0 then
1232	Dec(FillZeroCount)
1233	else
1234	begin
1235	tempIdObject := LoadNextFromStream(Stream);
1236	if tempIdObject = idArrayFiller then
1237	begin
1238	tempIdObject := 0;
1239	FillZeroCount := ArrayFillerCount;
1240	ArrayFillerCount := 0;
1241	end;
1242	if FillZeroCount > 0 then
1243	Dec(FillZeroCount)
1244	else
1245	plongword(ItemPtr[arrayIndex])^ := tempIdObject;
1246	end;
1247	end;
1248	end;
1249	except
1250	on ex: Exception do
1251	raise Exception.Create('Error while reading array of object. ' + ex.Message);
1252	end;
1253	end;
1254
1255	btArrayFiller8b, btArrayFiller32b:
1256	begin
1257	Result := idArrayFiller;
1258	arrayCount := 0;
1259	if blockType = btArrayFiller8b then
1260	arrayCount := WinReadByte(Stream)
1261	else
1262	arrayCount := WinReadLongWord(Stream);
1263	ArrayFillerCount := arraycount;
1264	end;
1265
1266	btGenericArray:
1267	begin
1268	try
1269	result := WinReadLongword(Stream);
1270	genericArrayType := TGenericArrayType( WinReadByte(Stream) );
1271	genericArrayRank := WinReadLongword(Stream);
1272	setlength(genericArrayDims,genericArrayRank);
1273	arrayCount := 0;
1274	if genericArrayRank <> 0 then
1275	for arrayIndex := 0 to genericArrayRank-1 do
1276	begin
1277	genericArrayDims[arrayIndex] := WinReadLongword(Stream);
1278	if arrayIndex=0 then
1279	arrayCount := genericArrayDims[arrayIndex]
1280	else
1281	arrayCount *= genericArrayDims[arrayIndex];
1282	end;
1283	genericArrayItemType.category := TTypeCategory(WinReadByte(Stream));
1284	genericArrayItemType := LoadFieldType(stream,genericArrayItemType.category);
1285
1286	newArrayObj := TSerializedArray.Create(self,genericArrayType,genericArrayItemType,genericArrayDims);
1287	setlength(objects, length(objects) + 1);
1288	objects[high(objects)] := newArrayObj;
1289	newArrayObj.idObject := result;
1290
1291	FillZeroCount := 0;
1292	if arrayCount <> 0 then
1293	for arrayIndex := 0 to arrayCount - 1 do
1294	begin
1295	if IsDotNetTypeStoredAsString(genericArrayItemType) then
1296	PString(newArrayObj.ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream,genericArrayItemType)
1297	else
1298	if genericArrayItemType.category = ftPrimitiveType then
1299	Stream.Read(newArrayObj.ItemPtr[arrayIndex]^, newArrayObj.ItemSize)
1300	else
1301	begin
1302	if FillZeroCount > 0 then
1303	Dec(FillZeroCount)
1304	else
1305	begin
1306	tempIdObject := LoadNextFromStream(Stream);
1307	if tempIdObject = idArrayFiller then
1308	begin
1309	tempIdObject := 0;
1310	FillZeroCount := ArrayFillerCount;
1311	ArrayFillerCount := 0;
1312	end;
1313	if FillZeroCount > 0 then
1314	Dec(FillZeroCount)
1315	else
1316	plongword(newArrayObj.ItemPtr[arrayIndex])^ := tempIdObject;
1317	end;
1318	end;
1319	end;
1320	except
1321	on ex: Exception do
1322	raise Exception.Create('Error while reading array of object. ' + ex.Message);
1323	end;
1324	end;
1325
1326	btMethodCall, btMethodResponse:
1327	raise Exception.Create('Method or method response not supported');
1328
1329	btEndOfStream: EndOfStream := True;
1330
1331	else
1332	raise Exception.Create('Unknown block type (' + IntToStr(blockType) + ')');
1333	end;
1334	end;
1335
1336	function TDotNetDeserialization.LoadStringFromStream(Stream: TStream): string;
1337	var
1338	byteLength, shift: byte;
1339	fullLength: integer;
1340	utf8value: string;
1341	begin
1342	fullLength := 0;
1343	shift := 0;
1344	{$hints off}
1345	repeat
1346	Stream.Read(byteLength, 1);
1347	Inc(fullLength, (byteLength and 127) shl shift);
1348	shift := shift + 7;
1349	until (byteLength < 128) or (shift > 24);
1350	{$hints on}
1351	setlength(utf8value, fullLength);
1352	if Stream.Read(utf8value[1], fullLength) <> fullLength then
1353	raise Exception.Create('String length error');
1354	Result := utf8value;
1355	end;
1356
1357	function TDotNetDeserialization.LoadDotNetCharFromStream(Stream: TStream
1358	): string;
1359	var
1360	tempByte: byte;
1361	dataLen: Byte;
1362	utf8value: string;
1363	begin
1364	tempByte:= WinReadByte(Stream);
1365
1366	if tempByte and $80 = 0 then
1367	dataLen := 1
1368	else
1369	if tempByte and $E0 = $C0 then
1370	dataLen := 2
1371	else
1372	if tempByte and $F0 = $E0 then
1373	dataLen := 3
1374	else
1375	if tempByte and $F8 = $F0 then
1376	dataLen := 4
1377	else
1378	raise Exception.Create('Invalid UTF8 char');
1379
1380	setlength(utf8value, dataLen);
1381	utf8value[1] := char(tempByte);
1382	Stream.Read(utf8value[2], dataLen - 1);
1383	Result := utf8value;
1384	end;
1385
1386	function TDotNetDeserialization.LoadTypeFromStream(Stream: TStream;
1387	IsRuntimeType: boolean): integer;
1388	var
1389	i: integer;
1390	begin
1391	try
1392	setlength(objectTypes, length(objectTypes) + 1);
1393	Result := high(objectTypes);
1394	with objectTypes[Result] do
1395	begin
1396	ClassName := LoadStringFromStream(Stream);
1397	nbFields := WinReadLongword(Stream);
1398	setlength(fieldNames, nbFields);
1399	setlength(fieldTypes, nbFields);
1400	for i := 0 to nbFields - 1 do
1401	fieldNames[i] := LoadStringFromStream(Stream);
1402	for i := 0 to nbFields - 1 do
1403	fieldTypes[i].category := TTypeCategory(WinReadByte(Stream));
1404	for i := 0 to nbFields - 1 do
1405	fieldTypes[i] := LoadFieldType(Stream,fieldTypes[i].category);
1406	if isRuntimeType then
1407	refAssembly := 0
1408	else
1409	refAssembly := WinReadLongword(Stream);
1410	end;
1411	except
1412	on ex: Exception do
1413	raise Exception.Create('Error while reading object type definition. ' +
1414	ex.Message);
1415	end;
1416	end;
1417
1418	function TDotNetDeserialization.LoadValuesFromStream(Stream: TStream;
1419	numType: integer): ArrayOfNameValue;
1420	var
1421	i: integer;
1422	ot: TSerializedType;
1423	begin
1424	if (numType < 0) or (numType > high(objectTypes)) then
1425	raise Exception.Create('Type number out of bounds (' + IntToStr(numType) + ')');
1426	ot := objectTypes[numType]; //use temp because array address may change
1427	try
1428	with ot do
1429	begin
1430	setlength(Result, nbFields);
1431	for i := 0 to nbFields - 1 do
1432	begin
1433	Result[i].Name := fieldNames[i];
1434	Result[i].valueType := fieldTypes[i].Name;
1435	Result[i].Value := LoadValueFromStream(Stream, fieldTypes[i]);
1436	end;
1437	end;
1438	except
1439	on ex: Exception do
1440	raise Exception.Create('Error while reading values of object of type ' +
1441	ot.ClassName + '. ' + ex.Message);
1442	end;
1443	end;
1444
1445	function TDotNetDeserialization.LoadValueFromStream(Stream: TStream;
1446	const fieldType: TFieldType): string;
1447	var
1448	data : record
1449	case byte of
1450	1: (ptr: pointer);
1451	2: (bytes: array[0..7] of byte);
1452	end;
1453	dataLen: longword;
1454	tempIdObject: longword;
1455	begin
1456	try
1457	if fieldType.Category = ftPrimitiveType then
1458	begin
1459	case fieldType.primitiveType of
1460	ptChar: Result := LoadDotNetCharFromStream(Stream);
1461	ptString, ptDecimal: Result := LoadStringFromStream(Stream);
1462	else
1463	begin
1464	dataLen := GetFieldTypeSize(fieldType);
1465	{$hints off}
1466	stream.read(data,dataLen);
1467	{$hints on}
1468	result := DotNetValueToString(data,fieldType);
1469	end;
1470	end;
1471	end else
1472	if fieldType.Category in [ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
1473	ftArrayOfString, ftArrayOfPrimitiveType] then
1474	begin
1475	tempIdObject := LoadNextFromStream(stream);
1476	Result := '#' + IntToStr(tempIdObject);
1477	end else
1478	raise Exception.Create('Unknown field type (' + IntToStr(
1479	byte(fieldType.category)) + ')');
1480	except
1481	on ex: Exception do
1482	raise Exception.Create('Error while reading object value. ' + ex.Message);
1483	end;
1484	end;
1485
1486	function TDotNetDeserialization.LoadFieldType(Stream: TStream; category: TTypeCategory
1487	): TFieldType;
1488	begin
1489	result.category := category;
1490	result.Name := '';
1491	result.refAssembly := 0;
1492	result.primitiveType := ptNone;
1493	case category of
1494	ftPrimitiveType, ftArrayOfPrimitiveType:
1495	begin
1496	result.primitiveType := TPrimitiveType(WinReadByte(stream));
1497	result.Name := PrimitiveTypeName(result.primitiveType);
1498	if result.category = ftArrayOfPrimitiveType then
1499	result.Name += '[]';
1500	end;
1501	ftString: result.Name := 'String';
1502	ftObjectType: result.Name := 'Object';
1503	ftRuntimeType: result.Name := LoadStringFromStream(Stream);
1504	ftGenericType:
1505	begin
1506	result.Name := LoadStringFromStream(Stream);
1507	result.refAssembly := WinReadLongword(Stream);
1508	end;
1509	ftArrayOfObject: result.Name := 'Object[]';
1510	ftArrayOfString: result.Name := 'String[]';
1511	else
1512	raise Exception.Create('Unknown field type tag (' + IntToStr(
1513	byte(result.category)) + ')');
1514	end;
1515	end;
1516
1517	initialization
1518
1519
1520	end.
1521

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/Packages/bgrabitmap/bgradnetdeserial.pas

Download in other formats: