bgradnetdeserial.pas

{ ***************************************************************************
 *                                                                          *
 *  This file is part of BGRABitmap library which is distributed under the  *
 *  modified LGPL.                                                          *
 *                                                                          *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,   *
 *  for details about the copyright.                                        *
 *                                                                          *
 *  This program is distributed in the hope that it will be useful,         *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of          *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    *
 *                                                                          *
 ************************* BGRABitmap library  ******************************

 - Drawing routines with transparency and antialiasing with Lazarus.
   Offers also various transforms.
 - These routines allow to manipulate 32bit images in BGRA format or RGBA
   format (depending on the platform).
 - This code is under modified LGPL (see COPYING.modifiedLGPL.txt).
   This means that you can link this library inside your programs for any purpose.
   Only the included part of the code must remain LGPL.

 - If you make some improvements to this library, please notify here:
   http://www.lazarus.freepascal.org/index.php/topic,12037.0.html

   ********************* Contact : Circular at operamail.com *******************


   ******************************* CONTRIBUTOR(S) ******************************
   - Edivando S. Santos Brasil | mailedivando@gmail.com
     (Compatibility with FPC ($Mode objfpc/delphi) and delphi VCL 11/2018)

   ***************************** END CONTRIBUTOR(S) *****************************}


Unit BGRADNetDeserial;

{$i bgrabitmap.inc}{$H+}{$H+}

interface

{ This unit allow to read .Net serialized classes with BinaryFormatter of
  namespace System.Runtime.Serialization.Formatters.Binary.

  Serialization is a process by which objects in memory are saved according
  to their structure.

  This unit is used by BGRAPaintNet to read Paint.NET images. }

uses
  Classes, BGRATypes,{$IFNDEF FPC}Types, GraphType, BGRAGraphics,{$ENDIF} SysUtils;

type
  arrayOfLongword = array of BGRALongWord;

  TTypeCategory = (ftPrimitiveType = 0, ftString = 1, ftObjectType =
    2, ftRuntimeType = 3,
    ftGenericType = 4, ftArrayOfObject = 5, ftArrayOfString = 6,
    ftArrayOfPrimitiveType = 7);

  TPrimitiveType = (ptNone = 0, ptBoolean = 1, ptByte = 2, ptChar = 3, ptDecimal = 5,
    ptDouble = 6, ptInt16 = 7, ptInt32 = 8, ptInt64 = 9, ptSByte = 10, ptSingle = 11,
    ptDateTime = 13, ptUInt16 = 14, ptUInt32 = 15, ptUInt64 = 16, ptString = 18);

  TGenericArrayType = (gatSingleDimension, gatJagged, gatMultidimensional);

  TDotNetDeserialization = class;

  ArrayOfNameValue = array of record
    Name: string;
    Value, valueType: string;
  end;

  TFieldType = record
    category: TTypeCategory;
    primitiveType: TPrimitiveType;
    refAssembly: BGRALongWord;
    Name: string;
  end;

  TSerializedType = record
    ClassName:   string;
    nbFields:    integer;
    fieldNames:  array of string;
    fieldTypes:  array of TFieldType;
    refAssembly: BGRALongWord;
  end;

  TAssemblyReference = record
    idAssembly: BGRALongWord;
    Name: string;
  end;

  { TCustomSerializedObject }

  TCustomSerializedObject = class
  protected
    FContainer: TDotNetDeserialization;
    function GetTypeAsString: string; virtual; abstract;
    function GetFieldAsString(Index: BGRALongWord): string; overload; virtual; abstract;
    function GetFieldAsString(Name: string): string; overload;
    function GetFieldCount: BGRALongWord; virtual; abstract;
    function GetFieldName(Index: BGRALongWord): string; virtual; abstract;
    function GetFieldTypeAsString(Index: BGRALongWord): string; virtual; abstract;
    function IsReferenceType(index: BGRALongWord): boolean; virtual; abstract;
  public
    idObject:   BGRALongWord;
    refCount:   integer;
    inToString: boolean;
    constructor Create(container: TDotNetDeserialization); virtual;
    property FieldCount: BGRALongWord read GetFieldCount;
    property FieldName[Index: BGRALongWord]:string read GetFieldName;
    property FieldAsString[Index: BGRALongWord]: string read GetFieldAsString;
    property FieldByNameAsString[Name: string]: string read GetFieldAsString;
    property FieldTypeAsString[Index: BGRALongWord]: string read GetFieldTypeAsString;
    property TypeAsString: string read GetTypeAsString;
    function GetFieldIndex(Name: string): integer;
  end;

  { TSerializedClass }

  TSerializedClass = class(TCustomSerializedObject)
  protected
    function GetFieldAsString(Index: BGRALongWord): string; override;
    function GetFieldCount: BGRALongWord; override;
    function GetFieldName(Index: BGRALongWord): string; override;
    function GetFieldTypeAsString(Index: BGRALongWord): string; override;
    function IsReferenceType(index: BGRALongWord): boolean; override;
    function GetTypeAsString: string; override;
  public
    numType: integer;
    fields:  ArrayOfNameValue;
  end;

  { TSerializedArray }

  TSerializedArray = class(TCustomSerializedObject)
  private
    data:       pointer;
    FItemSize:   BGRALongWord;
    function GetItemPtr(Index: BGRALongWord): pointer;
    procedure InitData;
  protected
    FArrayType: TGenericArrayType;
    function GetFieldAsString(Index: BGRALongWord): string; override;
    function GetFieldCount: BGRALongWord; override;
    function GetFieldName(Index: BGRALongWord): string; override;
    function GetFieldTypeAsString(Index: BGRALongWord): string; override;
    function IsReferenceType(index: BGRALongWord): boolean; override;
    function GetTypeAsString: string; override;
  public
    dimensions: array of BGRALongWord;
    itemType:   TFieldType;
    nbItems:    BGRALongWord;
    constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: BGRALongWord); overload;
    constructor Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType; ADimensions: arrayOfLongword); overload;
    destructor Destroy; override;
    property ItemPtr[Index:BGRALongWord]: pointer read GetItemPtr;
    property ItemSize: BGRALongWord read FItemSize;
  end;

  { TSerializedValue }

  TSerializedValue = class(TSerializedArray)
  protected
    function GetIsReferenceType: boolean;
    function GetValueAsString: string;
    function GetTypeAsString: string; override;
  public
    constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType); overload;
    property ValueAsString: string read GetValueAsString;
    property IsReferenceType: boolean read GetIsReferenceType;
  end;

  { TDotNetDeserialization }
  TDotNetDeserialization = class
    objectTypes: array of TSerializedType;
    assemblies:  array of TAssemblyReference;
    objects:     array of TCustomSerializedObject;

    function FindClass(typeName: string): TSerializedClass;
    function FindObject(typeName: string): TCustomSerializedObject;
    function GetSimpleField(obj: TCustomSerializedObject; Name: string): string; overload;
    function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject; overload;
    function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject; overload;
    function GetObject(id: string): TCustomSerializedObject; overload;
    function GetObject(id: BGRALongWord): TCustomSerializedObject; overload;
    function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean;
    function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string;
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromFile(filename: string);
    procedure LoadFromFileUTF8(filenameUTF8: string);
    function ToString: string; override;
    constructor Create;
    destructor Destroy; override;
    function GetTypeOfClassObject(idObject: BGRALongWord): integer;
  private
    EndOfStream:      boolean;
    ArrayFillerCount: BGRALongWord;
    currentAutoObjectValue: BGRALongWord;
    function nextAutoObjectId: BGRALongWord;
    function LoadNextFromStream(Stream: TStream): BGRALongWord;
    function LoadStringFromStream(Stream: TStream): string;
    function LoadDotNetCharFromStream(Stream: TStream): string;
    function LoadTypeFromStream(Stream: TStream; IsRuntimeType: boolean): integer;
    function LoadValuesFromStream(Stream: TStream; numType: integer): ArrayOfNameValue;
    function LoadValueFromStream(Stream: TStream; const fieldType: TFieldType): string;
    function LoadFieldType(Stream: TStream; category: TTypeCategory): TFieldType;
  end;

function WinReadByte(stream: TStream): byte;
function WinReadWord(Stream: TStream): BGRAWord;
function WinReadSmallInt(Stream: TStream): smallint;
function WinReadLongint(Stream: TStream): BGRALongInt;
function WinReadLongword(Stream: TStream): BGRALongWord;
function WinReadInt64(Stream: TStream): BGRAInt64;
function WinReadQWord(Stream: TStream): BGRAQWord;

implementation

uses BGRAUTF8;

const
  //block types
  btRefTypeObject = 1;
  btRuntimeObject = 4;
  btExternalObject = 5;
  btString      = 6;
  btGenericArray = 7;
  btBoxedPrimitiveTypeValue = 8;
  btObjectReference = 9;
  btNullValue   = 10;
  btEndOfStream = 11;
  btAssembly    = 12;
  btArrayFiller8b = 13;
  btArrayFiller32b = 14;
  btArrayOfPrimitiveType = 15;
  btArrayOfObject = 16;
  btArrayOfString = 17;
  btMethodCall  = 21;
  btMethodResponse = 22;

  idArrayFiller = $80000000;

{$hints off}

function WinReadByte(stream: TStream): byte;
begin
  stream.Read(Result, sizeof(Result));
end;

function WinReadWord(Stream: TStream): BGRAWord;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

function WinReadSmallInt(Stream: TStream): smallint;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

function WinReadLongint(Stream: TStream): BGRALongInt;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

function WinReadLongword(Stream: TStream): BGRALongWord;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

function WinReadInt64(Stream: TStream): BGRAInt64;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

function WinReadQWord(Stream: TStream): BGRAQWord;
begin
  stream.Read(Result, sizeof(Result));
  {$IFNDEF BDS}Result := LEtoN(Result);{$ENDIF}
end;

{$hints on}

function GetFieldTypeSize(const fieldType: TFieldType): BGRALongWord;
begin
  case fieldType.category of
    ftPrimitiveType:
      case fieldType.primitiveType of
        ptBoolean, ptByte,ptSByte: result := 1;
        ptChar,ptString, ptDecimal: Result := sizeof(string);
        ptsingle: result := sizeof(single);
        ptDouble: result := sizeof(double);
        ptInt16,ptUInt16: result := 2;
        ptInt32,ptUInt32: result := 4;
        ptInt64,ptUInt64,ptDateTime: result := 8;
      else
        raise Exception.Create('Unknown primitive type (' + IntToStr(
          byte(fieldType.primitiveType)) + ')');
      end;
    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
    ftArrayOfString, ftArrayOfPrimitiveType: result := 4;
  else
    raise Exception.Create('Unknown field type (' + IntToStr(
      byte(fieldType.category)) + ')');
  end;
end;

function IsDotNetTypeStoredAsString(const fieldType: TFieldType): boolean;
begin
  result := (fieldType.category = ftPrimitiveType) and
    (fieldType.primitiveType in [ptChar,ptString,ptDecimal]);
end;

function DotNetValueToString(var value; const fieldType: TFieldType): string;
var
  tempByte:     byte;
  value2bytes: record
    case byte of
    2: (tempWord: BGRAWord);
    3: (tempInt16: smallint);
  end;
  value4bytes: record
    case byte of
    1: (tempsingle:   single);
    2: (tempLongWord: BGRALongWord);
    3: (tempLongInt: BGRALongInt);
  end;
  value8bytes: record
    case byte of
    1: (tempDouble:   double);
    2: (tempInt64:    BGRAInt64);
    {$IFDEF OBJ}
    2: (tempUInt64:   BGRAQWord);
    {$ELSE}
    3: (tempUInt64:   BGRAQWord);
    {$ENDIF}
  end;
  tempIdObject: BGRALongWord;

begin
  if IsDotNetTypeStoredAsString(fieldType) then
  begin
    Result := pstring(@value)^;
    exit;
  end;
  case fieldType.category of
    ftPrimitiveType: case fieldType.primitiveType of
        ptBoolean:
        begin
          {$hints off}
          move(value,tempByte,sizeof(tempByte));
          {$hints on}
          if tempByte = 0 then
            Result := 'False'
          else
          if tempByte = 1 then
            Result := 'True'
          else
            raise Exception.Create('Invalid boolean value (' +
              IntToStr(tempByte) + ')');
        end;
        ptByte: Result := inttostr(pbyte(@value)^);
        ptSByte: Result := inttostr(pshortint(@value)^);
        ptInt16,ptUInt16:
        begin
          {$hints off}
          move(value, value2bytes.tempWord,sizeof(BGRAWord));
          {$hints on}
          {$IFNDEF BDS}value2bytes.tempWord := LEtoN(value2bytes.tempWord);{$ENDIF}
          if fieldType.primitiveType = ptInt16 then
            Result := IntToStr(value2bytes.tempInt16)
          else
            Result := IntToStr(value2bytes.tempWord);
        end;
        ptInt32,ptUInt32,ptsingle:
        begin
          {$hints off}
          move(value, value4bytes.tempLongWord,sizeof(BGRALongWord));
          {$hints on}
          {$IFNDEF BDS}value4bytes.tempLongWord := LEtoN(value4bytes.tempLongWord);{$ENDIF}
          if fieldType.primitiveType = ptInt32 then
            Result := IntToStr(value4bytes.tempLongInt)
          else if fieldType.primitiveType = ptUInt32 then
            Result := IntToStr(value4bytes.tempLongWord)
          else
            result := FloatToStr(value4bytes.tempsingle);
        end;

        ptInt64,ptUInt64,ptDouble,ptDateTime:
        begin
          {$hints off}
          move(value, value8bytes.tempUInt64,8);
          {$hints on}
          {$IFNDEF BDS}value8bytes.tempUInt64 := LEtoN(value8bytes.tempUInt64);{$ENDIF}
          if fieldType.primitiveType = ptInt64 then
            Result := IntToStr(value8bytes.tempInt64)
          else if fieldType.primitiveType = ptUInt64 then
            Result := IntToStr(value8bytes.tempUInt64)
          else if fieldType.primitiveType = ptDouble then
            result := FloatToStr(value8bytes.tempDouble)
          else
            Result := DateTimeToStr(
            (value8bytes.tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
        end;
        else
          raise Exception.Create('Unknown primitive type (' + IntToStr(
            byte(fieldType.primitiveType)) + ')');
      end;
    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
    ftArrayOfString, ftArrayOfPrimitiveType:
    begin
      {$hints off}
      move(value,tempIdObject,sizeof(tempIdObject));
      {$hints on}
      result := '#' + IntToStr(tempIdObject);
    end;
    else
      raise Exception.Create('Unknown field type (' + IntToStr(
        byte(fieldType.category)) + ')');
  end;
end;

function PrimitiveTypeName(pt: TPrimitiveType): string;
begin
  case pt of
    ptBoolean: Result  := 'Boolean';
    ptByte: Result     := 'Byte';
    ptChar: Result     := 'Char';
    ptDecimal: Result  := 'Decimal';
    ptDouble: Result   := 'Double';
    ptInt16: Result    := 'Int16';
    ptInt32: Result    := 'Int32';
    ptInt64: Result    := 'BGRAInt64';
    ptSByte: Result    := 'SByte';
    ptsingle: Result   := 'single';
    ptDateTime: Result := 'DateTime';
    ptUInt16: Result   := 'UInt16';
    ptUInt32: Result   := 'UInt32';
    ptUInt64: Result   := 'BGRAUInt64';
    ptString: Result   := 'String';
    else
      raise Exception.Create('Unknown primitive type (' + IntToStr(integer(pt)) + ')');
  end;
end;

Function DotNetTypeToString(ft: TFieldType): string;
begin
  if ft.category = ftPrimitiveType then
    result := PrimitiveTypeName(ft.primitiveType)
  else
    case ft.category of
      ftString: result := 'String';
      ftObjectType: result := 'Object';
      ftRuntimeType: result := 'RuntimeType';
      ftGenericType: result := 'GenericType';
      ftArrayOfObject: result := 'Object[]';
      ftArrayOfString: result := 'String[]';
      ftArrayOfPrimitiveType: result := 'PrimitiveType[]';
    else
      raise Exception.Create('Unknown field type (' + IntToStr(
        byte(ft.category)) + ')');
    end;
end;

{ TCustomSerializedObject }

function TCustomSerializedObject.GetFieldAsString(Name: string): string;
begin
  result := GetFieldAsString(GetFieldIndex(Name));
end;

constructor TCustomSerializedObject.Create(container: TDotNetDeserialization);
begin
  FContainer := container;
  refCount := 0;
end;

function TCustomSerializedObject.GetFieldIndex(Name: string): integer;
var
  i: integer;
  fn: string;
begin
  if FieldCount = 0 then
  begin
    result := -1;
    exit;
  end;
  //case sensitive
  for i := 0 to FieldCount-1 do
    if FieldName[i] = Name then
    begin
      Result := i;
      exit;
    end;
  //case insensitive
  for i := 0 to FieldCount-1 do
    if compareText(FieldName[i], Name) = 0 then
    begin
      Result := i;
      exit;
    end;
  //case sensitive inner member
  for i := 0 to FieldCount-1 do
  begin
    fn := FieldName[i];
    if (length(Name) < length(fn)) and
      (copy(fn, length(fn) - length(Name),
      length(Name) + 1) = '+' + Name) then
    begin
      Result := i;
      exit;
    end;
  end;
  //case insensitive inner member
  for i := 0 to FieldCount-1 do
  begin
    fn := FieldName[i];
    if (length(Name) < length(fn)) and
      (compareText(copy(fn, length(fn) -
      length(Name), length(Name) + 1), '+' + Name) = 0) then
    begin
      Result := i;
      exit;
    end;
  end;
  Result := -1;
end;

{ TSerializedClass }

function TSerializedClass.GetFieldAsString(Index: BGRALongWord): string;
begin
  result := fields[Index].Value;
end;

function TSerializedClass.GetFieldCount: BGRALongWord;
begin
  Result:= length(fields);
end;

function TSerializedClass.GetFieldName(Index: BGRALongWord): string;
begin
  result := fields[Index].Name;
end;

function TSerializedClass.GetFieldTypeAsString(Index: BGRALongWord): string;
begin
  result := fields[Index].valueType;
end;

function TSerializedClass.IsReferenceType(index: BGRALongWord): boolean;
begin
  Result:= FContainer.objectTypes[numType].fieldTypes[index].category <> ftPrimitiveType;
end;

function TSerializedClass.GetTypeAsString: string;
begin
  Result:= FContainer.objectTypes[numType].ClassName;
end;

{ TSerializedArray }

procedure TSerializedArray.InitData;
begin
  FItemSize := GetFieldTypeSize(itemType);
  getmem(data, itemSize*nbItems);
  fillchar(data^, itemSize*nbItems, 0);
end;

function TSerializedArray.GetItemPtr(Index: BGRALongWord): pointer;
begin
  if index >= nbItems then
    raise exception.Create('Index out of bounds');
  result := pointer(pbyte(data)+Index*itemsize);
end;

function TSerializedArray.GetFieldAsString(Index: BGRALongWord): string;
begin
  if data = nil then
    result := ''
  else
    result := DotNetValueToString(ItemPtr[index]^, itemType);
end;

function TSerializedArray.GetFieldCount: BGRALongWord;
begin
  Result:= nbItems;
end;

function TSerializedArray.GetFieldName(Index: BGRALongWord): string;
var
  r: BGRALongWord;
begin
  result := '[';
  for r := 1 to length(dimensions) do
  begin
    if r <> 1 then result:=result+',';
    result := result +inttostr(index mod dimensions[r-1]);
    index := index div dimensions[r-1];
  end;
  result := result +']';
end;

{$hints off}
function TSerializedArray.GetFieldTypeAsString(Index: BGRALongWord): string;
begin
  Result:= DotNetTypeToString(itemType);
end;
{$hints on}

{$hints off}
function TSerializedArray.IsReferenceType(index: BGRALongWord): boolean;
begin
  Result:= itemType.category <> ftPrimitiveType;
end;
{$hints on}

function TSerializedArray.GetTypeAsString: string;
var
  i: Integer;
begin
  Result:= DotNetTypeToString(itemType)+'[';
  for i := 2 to length(dimensions) do
    result := result +',';
  result := result +']';
end;

constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: BGRALongWord);
begin
  inherited Create(AContainer);
  setlength(dimensions,1);
  dimensions[0] := ALength;
  nbItems := ALength;
  FArrayType := gatSingleDimension;
  itemType := AItemType;
  InitData;
end;

constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType;
  ADimensions: arrayOfLongword);
var n: BGRALongWord;
begin
  inherited Create(AContainer);
  setlength(dimensions, length(ADimensions));
  nbItems := 1;
  if length(ADimensions) <> 0 then
    for n := 0 to length(ADimensions)-1 do
    begin
      dimensions[n] := ADimensions[n];
      nbItems := nbItems *ADimensions[n];
    end;
  FArrayType := AArrayType;
  itemType := AItemType;
  InitData;
end;

destructor TSerializedArray.Destroy;
var ps: PString;
  n: BGRALongWord;
begin
  if IsDotNetTypeStoredAsString(itemType) and (nbItems <> 0) then
  begin
    ps := PString(data);
    for n := 1 to nbItems do
    begin
      ps^ := '';
      inc(ps);
    end;
  end;
  freemem(data);
  inherited Destroy;
end;

{ TSerializedValue }

function TSerializedValue.GetIsReferenceType: boolean;
begin
  result := inherited IsReferenceType(0);
end;

function TSerializedValue.GetValueAsString: string;
begin
  result := GetFieldAsString(0);
end;

function TSerializedValue.GetTypeAsString: string;
begin
  Result:= GetFieldTypeAsString(0);
end;

constructor TSerializedValue.Create(AContainer: TDotNetDeserialization;
  AItemType: TFieldType);
begin
  inherited Create(AContainer,AItemType,1);
end;

{ TDotNetDeserialization }

function TDotNetDeserialization.FindClass(typeName: string): TSerializedClass;
var obj: TCustomSerializedObject;
begin
  obj := FindObject(typeName);
  if obj is TSerializedClass then
    result := obj as TSerializedClass
  else
    raise exception.Create('FindClass: found object is not a class');
end;

function TDotNetDeserialization.FindObject(typeName: string): TCustomSerializedObject;
var
  i:   integer;
  comparedType: string;
begin
  for i := 0 to high(objects) do
  begin
    comparedType := objects[i].TypeAsString;
    if (comparedType = typeName) or
      ( (length(typeName) < length(comparedType) ) and
        (copy(comparedType, length(comparedType) - length(typeName),
        length(typeName) + 1) = '.' + typeName) ) then
    begin
      Result := objects[i];
      exit;
    end;
  end;
  Result := nil;
end;

function TDotNetDeserialization.GetSimpleField(obj: TCustomSerializedObject;
  Name: string): string;
var
  i,idxSlash: integer;
  tempSub: TCustomSerializedObject;
begin
  i := obj.GetFieldIndex(Name);
  if i = -1 then
  begin
    idxSlash := pos('\',name);
    if idxSlash <> 0 then
    begin
      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
      if tempSub <> nil then
      begin
        result := GetSimpleField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
        exit;
      end;
    end;
    Result := ''
  end
  else
  begin
    if IsBoxedValue(obj, i) then
      Result := GetBoxedValue(obj, i)
    else
      Result := obj.FieldAsString[i];
  end;
end;

function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
  Name: string): TCustomSerializedObject;
var
  i: integer;
  idxSlash: BGRALongInt;
  tempSub: TCustomSerializedObject;
begin
  i := obj.GetFieldIndex(Name);
  if i = -1 then
  begin
    idxSlash := pos('\',name);
    if idxSlash <> 0 then
    begin
      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
      if tempSub <> nil then
      begin
        result := GetObjectField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
        exit;
      end;
    end;
    Result := nil
  end
  else
  begin
    if not obj.IsReferenceType(i) then
      raise Exception.Create('GetObjectField: Not a reference type');
    Result := GetObject(obj.FieldAsString[i]);
  end;
end;

function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
  index: integer): TCustomSerializedObject;
begin
  if not obj.IsReferenceType(index) then
    raise Exception.Create('GetObjectField: Not a reference type');
  Result := GetObject(obj.FieldAsString[index]);
end;

function TDotNetDeserialization.GetObject(id: string): TCustomSerializedObject;
var
  idObj: BGRALongWord;
begin
  if copy(id, 1, 1) = '#' then
    Delete(id, 1, 1);
  idObj  := StrToInt64(id);
  Result := GetObject(idObj);
end;

function TDotNetDeserialization.GetObject(id: BGRALongWord): TCustomSerializedObject;
var
  i: integer;
begin
  for i := 0 to high(objects) do
    if objects[i].idObject = id then
    begin
      Result := objects[i];
      exit;
    end;
  Result := nil;
end;

function TDotNetDeserialization.IsBoxedValue(obj: TCustomSerializedObject;
  index: integer): boolean;
var
  subObj: TCustomSerializedObject;
begin
  if not obj.IsReferenceType(index) then
  begin
    Result := False;
    exit;
  end;
  subObj := GetObject(obj.FieldAsString[index]);
  if subObj = nil then //suppose Nothing is a boxed value
  begin
    Result := True;
    exit;
  end;
  Result := subObj is TSerializedValue;
end;

function TDotNetDeserialization.GetBoxedValue(obj: TCustomSerializedObject;
  index: integer): string;
var
  subObj: TCustomSerializedObject;
begin
  if not obj.IsReferenceType(index) then
    raise Exception.Create('GetBoxedValue: Not a reference type');
  subObj := GetObject(obj.FieldAsString[index]);
  if subObj = nil then
  begin
    Result := ''; //empty value
    exit;
  end;
  if (subObj is TSerializedValue) and not (subObj as TSerializedValue).IsReferenceType then
    Result := (subObj as TSerializedValue).ValueAsString
  else
    raise Exception.Create('GetBoxedValue: Not a primitive type');
end;

procedure TDotNetDeserialization.LoadFromStream(Stream: TStream);
var
  header: packed record
    blockId: byte;
    value1, value2, value3, value4: BGRALongInt;
  end;
  curStreamPosition, prevStreamPosition: BGRAInt64;
begin
  {$hints off}
  if Stream.Read(header, sizeof(header)) <> sizeof(header) then
    raise Exception.Create('Invalid header size');
  if (header.blockId <> 0) or (header.value1 <> 1) or (header.value2 <> -1) or
    (header.value3 <> 1) or (header.value4 <> 0) then
    raise Exception.Create('Invalid header format');
  {$hints on}

  EndOfStream := False;
  curStreamPosition := Stream.Position;
  try
    while (Stream.Position < Stream.Size) and not EndOfStream do
    begin
      prevStreamPosition := curStreamPosition;
      curStreamPosition  := Stream.Position;
      LoadNextFromStream(Stream);
    end;
  except
    on ex: Exception do
      raise Exception.Create('Error while loading serialized data at position ' +
        IntToStr(stream.Position) + ' (block starting at ' +
        IntToStr(curStreamPosition) + ', previous block at ' +
        IntToStr(prevStreamPosition) + '). ' + ex.message);
  end;
end;

procedure TDotNetDeserialization.LoadFromFile(filename: string);
var
  stream: TFileStream;
begin
  stream := TFileStream.Create(filename, fmOpenRead);
  try
    LoadFromStream(stream);
  finally
    stream.Free;
  end;
end;

procedure TDotNetDeserialization.LoadFromFileUTF8(filenameUTF8: string);
var
  stream: TFileStreamUTF8;
begin
  stream := TFileStreamUTF8.Create(filenameUTF8, fmOpenRead);
  try
    LoadFromStream(stream);
  finally
    stream.Free;
  end;
end;

function TDotNetDeserialization.ToString: string;

  function ObjectToString(num: integer; expectedType: string;
    tab: string; main: boolean): string;
  var
    j, k:   integer;
    subId:  BGRALongWord;
    subNum: integer;
    objType, subExpectedType: string;
    fieldTypeStr: string;
  begin
    Result := '';
    if (num < 0) or (num > high(objects)) then
      raise Exception.Create('Index out of bounds');
    with objects[num] do  //here array is not changed so it won't move
    begin
      if inToString then
      begin
        if main then
          Result := ''
        else
          Result := '#' + IntToStr(idObject) + LineEnding;
        exit;
      end;
      inToString := True;
      objType := TypeAsString;
      if main then
      begin
        Result := result +tab + 'Object';
        Result := result +' #' + IntToStr(idObject);
        if (objType = '') or (objType = expectedType) then
          Result := result +' = '
        else
          Result := result +' As ' + objType + ' = ';
      end
      else
      begin
        if (objType = '') or (objType = expectedType) then
          Result := ''
        else
          Result := '(' + objType + ') ';
        if (idObject < idArrayFiller) and (refCount > 0) then
          Result := result +'#' + IntToStr(idObject) + ' = ';
      end;
      if (length(objType) > 2) and (copy(objType, length(objType) - 1, 2) = '[]') then
        subExpectedType := copy(objType, 1, length(objType) - 2)
      else
        subExpectedType := '';

      if not main and (objects[num] is TSerializedValue) then
      begin
        Result := result +(objects[num] as TSerializedValue).ValueAsString + LineEnding;
      end
      else
      if (FieldCount = 0) then
      begin
        Result := result +'{}' + LineEnding;
      end
      else
      begin
        Result := result +'{' + LineEnding;
        for j := 0 to FieldCount-1 do
        begin
          Result := result +tab + '  ' + FieldName[j];
          fieldTypeStr := FieldTypeAsString[j];
          if (fieldTypeStr <> '') and (fieldTypeStr <> subExpectedType) and
            not ((subExpectedType = '') and ((fieldTypeStr = 'Int32') or
            (fieldTypeStr = 'Boolean') or (fieldTypeStr = 'Double'))) then
            Result := result +' As ' + fieldTypeStr;
          Result   := result +' = ';
          if not IsReferenceType(j) then
            Result := result + FieldAsString[j] + lineending
          else
          begin
            try
              subId  := StrToInt64(copy(fieldAsString[j], 2, length(fieldAsString[j]) - 1));
              if subId = 0 then result := result + 'null'+LineEnding else
              begin
                begin
                  subNum := -1;
                  for k := 0 to high(objects) do
                  if (objects[k].idObject = subId) then
                  begin
                    subNum := k;
                    break;
                  end;
                end;
                if subNum = -1 then
                  Result := result +'(Not found) #' + IntToStr(subId)+LineEnding
                else
                  Result := result + objectToString(subNum, fieldTypeStr, tab + '  ', False);
              end;
            except
              result := result +'!' + fieldAsString[j]+'!' +LineEnding
            end;
          end;
        end;
        Result := result + tab + '}' + LineEnding;
        if main then
          Result := result + LineEnding;
      end;
    end;
  end;

var
  i: integer;
begin
  Result := '';
  for i := 0 to high(assemblies) do
    Result := result +'Imports ' + assemblies[i].Name + LineEnding;
  Result   := result +lineEnding;
  for i := 0 to high(objects) do
    objects[i].inToString := False;
  for i := 0 to high(objects) do
    Result := result +ObjectToString(i, 'Object', '', True);
end;

constructor TDotNetDeserialization.Create;
begin
  currentAutoObjectValue := idArrayFiller + 1;
end;

destructor TDotNetDeserialization.Destroy;
var
  i: Integer;
begin
  for i := 0 to high(objects) do
    objects[i].Free;
  inherited Destroy;
end;

function TDotNetDeserialization.GetTypeOfClassObject(idObject: BGRALongWord
  ): integer;
var
  i: Integer;
begin
  for i := 0 to high(objects) do
    if objects[i].idObject = idObject then
    begin
      if objects[i] is TSerializedClass then
      begin
        result := (objects[i] as TSerializedClass).numType;
        exit;
      end
      else
        raise exception.Create('GetTypeOfClassObject: Specified object is not of class type');
    end;
  raise exception.Create('GetTypeOfClassObject: Object not found');
end;

function TDotNetDeserialization.nextAutoObjectId: BGRALongWord;
begin
  Inc(currentAutoObjectValue);
  Result := currentAutoObjectValue;
end;

function TDotNetDeserialization.LoadNextFromStream(Stream: TStream): BGRALongWord;
var
  blockType:    byte;
  idRefObject, tempIdObject: BGRALongWord;
  tempType:     TFieldType;
  arrayCount, arrayIndex,FillZeroCount : BGRALongWord;
  tempAnyObj: TCustomSerializedObject;
  newClassObj: TSerializedClass;
  newValueObj: TSerializedValue;
  newArrayObj: TSerializedArray;
  genericArrayType: TGenericArrayType;
  genericArrayRank: BGRALongWord;
  genericArrayDims: {$IFDEF BDS}arrayOfLongword{$ELSE}array of BGRALongWord{$ENDIF};
  genericArrayItemType: TFieldType;

  function GetArrayCellNumber(index: BGRALongWord): string;
  var r: BGRALongWord;
  begin
    result := '';
    for r := 1 to genericArrayRank do
    begin
      if r <> 1 then result:=result +',';
      result := result +inttostr(index mod genericArrayDims[r-1]);
      index := index div genericArrayDims[r-1];
    end;
  end;

begin
  Result := 0; //idObject or zero
  blockType := WinReadByte(Stream);
  case blockType of

    btAssembly:
    begin
      setlength(assemblies, length(assemblies) + 1);
      with assemblies[high(assemblies)] do
      begin
        idAssembly := WinReadLongword(Stream);
        Name := LoadStringFromStream(Stream);
      end;
    end;

    btRuntimeObject, btExternalObject:
    begin
      newClassObj := TSerializedClass.Create(self);
      setlength(objects, length(objects) + 1);
      objects[high(objects)] := newClassObj;
      with newClassObj do
      begin
        idObject := WinReadLongword(Stream);
        Result   := idObject;
        numType  := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
        fields   := LoadValuesFromStream(Stream, numType);
      end;
    end;

    btRefTypeObject:
    begin
      newClassObj := TSerializedClass.Create(self);
      setlength(objects, length(objects) + 1);
      objects[high(objects)] := newClassObj;
      with newClassObj do
      begin
        idObject    := WinReadLongword(Stream);
        Result      := idObject;
        idRefObject := WinReadLongword(Stream);
        numType     := GetTypeOfClassObject(idRefObject);
        fields      := LoadValuesFromStream(Stream, numType);
      end;
    end;

    btString:
    begin
      tempType.primitiveType := ptString;
      tempType.category := ftPrimitiveType;
      tempType.Name := PrimitiveTypeName(ptString);
      tempType.refAssembly := 0;

      newValueObj := TSerializedValue.Create(self,tempType);
      setlength(objects, length(objects) + 1);
      objects[high(objects)] := newValueObj;
      with newValueObj do
      begin
        idObject := WinReadLongword(Stream);
        Result  := idObject;
        pstring(data)^ := LoadStringFromStream(Stream);
      end;
    end;

    btBoxedPrimitiveTypeValue:
    begin
      try
        tempType.category    := ftPrimitiveType;
        tempType.refAssembly := 0;
        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
        tempType.Name := PrimitiveTypeName(tempType.primitiveType);

        newValueObj := TSerializedValue.Create(self,tempType);
        setlength(objects, length(objects) + 1);
        objects[high(objects)] := newValueObj;

        with newValueObj do
        begin
          idObject := nextAutoObjectId;
          Result   := idObject;

          if IsDotNetTypeStoredAsString(tempType) then
            pstring(data)^ := LoadValueFromStream(Stream, tempType)
          else
            Stream.Read(data^, itemSize);
        end;
      except
        on ex: Exception do
          raise Exception.Create('Error while reading boxed primitive values. ' +
            ex.Message);
      end;
    end;

    btObjectReference:
    begin
      result := WinReadLongword(Stream);
      tempAnyObj := GetObject(Result);
      if tempAnyObj <> nil then
        Inc(tempAnyObj.refCount);
    end;

    btNullValue: Result := 0;

    btArrayOfPrimitiveType:
    begin
      try
        result := WinReadLongword(Stream);
        arrayCount := WinReadLongword(Stream);

        tempType.category    := ftPrimitiveType;
        tempType.refAssembly := 0;
        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
        tempType.Name := PrimitiveTypeName(tempType.primitiveType);

        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
        setlength(objects, length(objects) + 1);
        objects[high(objects)] := newArrayObj;
        with newArrayObj do
        begin
          idObject := result;

          if arrayCount <> 0 then
          begin
            if IsDotNetTypeStoredAsString(tempType) then
            begin
              for arrayIndex := 0 to arrayCount - 1 do
                pstring(ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream, tempType);
            end else
            begin
              for arrayIndex := 0 to arrayCount - 1 do
                stream.Read(ItemPtr[arrayIndex]^, itemSize);
            end;
          end;
        end;
      except
        on ex: Exception do
          raise Exception.Create('Error while reading array of primitive values. ' +
            ex.Message);
      end;
    end;

    btArrayOfObject,btArrayOfString:
    begin
      try
        result := WinReadLongword(Stream);
        arrayCount := WinReadLongword(Stream);

        if blockType = btArrayOfObject then
          tempType.category := ftObjectType
        else
          tempType.category := ftString;

        tempType.refAssembly := 0;
        tempType.primitiveType := ptNone;
        tempType.Name := DotNetTypeToString(tempType);

        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
        setlength(objects, length(objects) + 1);
        objects[high(objects)] := newArrayObj;

        with newArrayObj do
        begin
          idObject:= result;
          FillZeroCount := 0;
          if arrayCount <> 0 then
            for arrayIndex := 0 to arrayCount - 1 do
            begin
              if FillZeroCount > 0 then
                Dec(FillZeroCount)
              else
              begin
                tempIdObject := LoadNextFromStream(Stream);
                if tempIdObject = idArrayFiller then
                begin
                  tempIdObject     := 0;
                  FillZeroCount    := ArrayFillerCount;
                  ArrayFillerCount := 0;
                end;
                if FillZeroCount > 0 then
                  Dec(FillZeroCount)
                else
                  plongword(ItemPtr[arrayIndex])^ := tempIdObject;
              end;
            end;
        end;
      except
        on ex: Exception do
          raise Exception.Create('Error while reading array of object. ' + ex.Message);
      end;
    end;

    btArrayFiller8b, btArrayFiller32b:
    begin
      Result     := idArrayFiller;
      arrayCount := 0;
      if blockType = btArrayFiller8b then
        arrayCount := WinReadByte(Stream)
      else
        arrayCount := WinReadLongWord(Stream);
      ArrayFillerCount := arraycount;
    end;

    btGenericArray:
    begin
        try
          result := WinReadLongword(Stream);
          genericArrayType := TGenericArrayType( WinReadByte(Stream) );
          genericArrayRank := WinReadLongword(Stream);
          setlength(genericArrayDims,genericArrayRank);
          arrayCount := 0;
          if genericArrayRank <> 0 then
            for arrayIndex := 0 to genericArrayRank-1 do
            begin
              genericArrayDims[arrayIndex] := WinReadLongword(Stream);
              if arrayIndex=0 then
                arrayCount := genericArrayDims[arrayIndex]
              else
                arrayCount := arrayCount *genericArrayDims[arrayIndex];
            end;
          genericArrayItemType.category := TTypeCategory(WinReadByte(Stream));
          genericArrayItemType := LoadFieldType(stream,genericArrayItemType.category);

          newArrayObj := TSerializedArray.Create(self,genericArrayType,genericArrayItemType,genericArrayDims);
          setlength(objects, length(objects) + 1);
          objects[high(objects)] := newArrayObj;
          newArrayObj.idObject := result;

          FillZeroCount := 0;
          if arrayCount <> 0 then
            for arrayIndex := 0 to arrayCount - 1 do
            begin
              if IsDotNetTypeStoredAsString(genericArrayItemType) then
                PString(newArrayObj.ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream,genericArrayItemType)
              else
              if genericArrayItemType.category = ftPrimitiveType then
                Stream.Read(newArrayObj.ItemPtr[arrayIndex]^, newArrayObj.ItemSize)
              else
              begin
                if FillZeroCount > 0 then
                  Dec(FillZeroCount)
                else
                begin
                  tempIdObject := LoadNextFromStream(Stream);
                  if tempIdObject = idArrayFiller then
                  begin
                    tempIdObject     := 0;
                    FillZeroCount    := ArrayFillerCount;
                    ArrayFillerCount := 0;
                  end;
                  if FillZeroCount > 0 then
                    Dec(FillZeroCount)
                  else
                    PBGRALongWord(newArrayObj.ItemPtr[arrayIndex])^ := tempIdObject;
                end;
              end;
            end;
        except
          on ex: Exception do
            raise Exception.Create('Error while reading array of object. ' + ex.Message);
        end;
      end;

    btMethodCall, btMethodResponse:
      raise Exception.Create('Method or method response not supported');

    btEndOfStream: EndOfStream := True;

    else
      raise Exception.Create('Unknown block type (' + IntToStr(blockType) + ')');
  end;
end;

function TDotNetDeserialization.LoadStringFromStream(Stream: TStream): string;
var
  byteLength, shift: byte;
  fullLength: integer;
  utf8value:  string;
begin
  fullLength := 0;
  shift      := 0;
     {$hints off}
  repeat
    Stream.Read(byteLength, 1);
    Inc(fullLength, (byteLength and 127) shl shift);
    shift := shift + 7;
  until (byteLength < 128) or (shift > 24);
     {$hints on}
  setlength(utf8value, fullLength);
  if Stream.Read(utf8value[1], fullLength) <> fullLength then
    raise Exception.Create('String length error');
  Result := utf8value;
end;

function TDotNetDeserialization.LoadDotNetCharFromStream(Stream: TStream
  ): string;
var
  tempByte: byte;
  dataLen: Byte;
  utf8value: string;
begin
  tempByte:= WinReadByte(Stream);

  if tempByte and $80 = 0 then
    dataLen := 1
  else
  if tempByte and $E0 = $C0 then
    dataLen := 2
  else
  if tempByte and $F0 = $E0 then
    dataLen := 3
  else
  if tempByte and $F8 = $F0 then
    dataLen := 4
  else
    raise Exception.Create('Invalid UTF8 char');

  setlength(utf8value, dataLen);
  utf8value[1] := Char(tempByte);
  Stream.Read(utf8value[2], dataLen - 1);
  Result := utf8value;
end;

function TDotNetDeserialization.LoadTypeFromStream(Stream: TStream;
  IsRuntimeType: boolean): integer;
var
  i: integer;
begin
  try
    setlength(objectTypes, length(objectTypes) + 1);
    Result := high(objectTypes);
    with objectTypes[Result] do
    begin
      ClassName := LoadStringFromStream(Stream);
      nbFields := WinReadLongword(Stream);
      setlength(fieldNames, nbFields);
      setlength(fieldTypes, nbFields);
      for i := 0 to nbFields - 1 do
        fieldNames[i] := LoadStringFromStream(Stream);
      for i := 0 to nbFields - 1 do
        fieldTypes[i].category := TTypeCategory(WinReadByte(Stream));
      for i := 0 to nbFields - 1 do
        fieldTypes[i] := LoadFieldType(Stream,fieldTypes[i].category);
      if isRuntimeType then
        refAssembly := 0
      else
        refAssembly := WinReadLongword(Stream);
    end;
  except
    on ex: Exception do
      raise Exception.Create('Error while reading object type definition. ' +
        ex.Message);
  end;
end;

function TDotNetDeserialization.LoadValuesFromStream(Stream: TStream;
  numType: integer): ArrayOfNameValue;
var
  i:  integer;
  ot: TSerializedType;
begin
  if (numType < 0) or (numType > high(objectTypes)) then
    raise Exception.Create('Type number out of bounds (' + IntToStr(numType) + ')');
  ot := objectTypes[numType]; //use temp because array address may change
  try
    with ot do
    begin
      setlength(Result, nbFields);
      for i := 0 to nbFields - 1 do
      begin
        Result[i].Name      := fieldNames[i];
        Result[i].valueType := fieldTypes[i].Name;
        Result[i].Value     := LoadValueFromStream(Stream, fieldTypes[i]);
      end;
    end;
  except
    on ex: Exception do
      raise Exception.Create('Error while reading values of object of type ' +
        ot.ClassName + '. ' + ex.Message);
  end;
end;

function TDotNetDeserialization.LoadValueFromStream(Stream: TStream;
  const fieldType: TFieldType): string;
var
  data : record
    case byte of
    1: (ptr: pointer);
    2: (bytes: array[0..7] of byte);
    end;
  dataLen: BGRALongWord;
  tempIdObject: BGRALongWord;
begin
  try
    if fieldType.Category = ftPrimitiveType then
    begin
      case fieldType.primitiveType of
        ptChar: Result := LoadDotNetCharFromStream(Stream);
        ptString, ptDecimal: Result := LoadStringFromStream(Stream);
      else
        begin
          dataLen := GetFieldTypeSize(fieldType);
          {$hints off}
          stream.read(data,dataLen);
          {$hints on}
          result := DotNetValueToString(data,fieldType);
        end;
      end;
    end else
    if fieldType.Category in [ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
        ftArrayOfString, ftArrayOfPrimitiveType] then
    begin
      tempIdObject := LoadNextFromStream(stream);
      Result := '#' + IntToStr(tempIdObject);
    end else
      raise Exception.Create('Unknown field type (' + IntToStr(
        byte(fieldType.category)) + ')');
  except
    on ex: Exception do
      raise Exception.Create('Error while reading object value. ' + ex.Message);
  end;
end;

function TDotNetDeserialization.LoadFieldType(Stream: TStream; category: TTypeCategory
  ): TFieldType;
begin
  result.category := category;
  result.Name := '';
  result.refAssembly := 0;
  result.primitiveType := ptNone;
  case category of
    ftPrimitiveType, ftArrayOfPrimitiveType:
    begin
      result.primitiveType := TPrimitiveType(WinReadByte(stream));
      result.Name := PrimitiveTypeName(result.primitiveType);
      if result.category = ftArrayOfPrimitiveType then
        result.Name := result.Name +'[]';
    end;
    ftString: result.Name      := 'String';
    ftObjectType: result.Name  := 'Object';
    ftRuntimeType: result.Name := LoadStringFromStream(Stream);
    ftGenericType:
    begin
      result.Name := LoadStringFromStream(Stream);
      result.refAssembly := WinReadLongword(Stream);
    end;
    ftArrayOfObject: result.Name := 'Object[]';
    ftArrayOfString: result.Name := 'String[]';
    else
      raise Exception.Create('Unknown field type tag (' + IntToStr(
        byte(result.category)) + ')');
  end;
end;

initialization


end.