Ignore:
Timestamp:
Feb 1, 2012, 3:02:33 PM (12 years ago)
Author:
chronos
Message:
  • Modified: Updated BGRABitmap package to version 5.5.
  • Modified: Removed draw method ComboBox and reorganized method list to single listview with using ownerdraw facility.
  • Added: New draw method TBitmap.RawImage.Data Move which use fast Move operation. It requires same pixel format.
  • Added: New draw method Dummy for comparion of empty method and to determine possibily max frame rate limit.
Location:
GraphicTest/BGRABitmap
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • GraphicTest/BGRABitmap

    • Property svn:ignore set to
      lib

  • GraphicTest/BGRABitmap/bgradnetdeserial.pas

    r210 r317  
    44
    55interface
     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. }
    614
    715uses
    … …  
    917
    1018type
     19  arrayOfLongword = array of longword;
     20
    1121  TTypeCategory = (ftPrimitiveType = 0, ftString = 1, ftObjectType =
    1222    2, ftRuntimeType = 3,
    … …  
    1727    ptDouble = 6, ptInt16 = 7, ptInt32 = 8, ptInt64 = 9, ptSByte = 10, ptSingle = 11,
    1828    ptDateTime = 13, ptUInt16 = 14, ptUInt32 = 15, ptUInt64 = 16, ptString = 18);
     29
     30  TGenericArrayType = (gatSingleDimension, gatJagged, gatMultidimensional);
     31
     32  TDotNetDeserialization = class;
    1933
    2034  ArrayOfNameValue = array of record
    … …  
    4357  end;
    4458
    45   PSerializedObject = ^TSerializedObject;
    46 
    47   TSerializedObject = record
     59  { TCustomSerializedObject }
     60
     61  TCustomSerializedObject = class
     62  protected
     63    FContainer: TDotNetDeserialization;
     64    function GetTypeAsString: string; virtual; abstract;
     65    function GetFieldAsString(Index: longword): string; virtual; abstract;
     66    function GetFieldAsString(Name: string): string;
     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
    4872    idObject:   longword;
    49     numType:    integer;
    50     fields:     ArrayOfNameValue;
    5173    refCount:   integer;
    5274    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;
    53138  end;
    54139
    … …  
    57142    objectTypes: array of TSerializedType;
    58143    assemblies:  array of TAssemblyReference;
    59     objects:     array of TSerializedObject;
    60 
    61     function FindObject(typeName: string): PSerializedObject;
    62     function GetSimpleField(obj: TSerializedObject; Name: string): string;
    63     function FieldIndex(obj: TSerializedObject; Name: string): integer;
    64     function GetObjectField(obj: TSerializedObject; Name: string): PSerializedObject;
    65     function GetObject(id: string): PSerializedObject;
    66     function GetObject(id: longword): PSerializedObject;
    67     function GetObjectType(obj: PSerializedObject): string;
    68     function PrimitiveTypeName(pt: TPrimitiveType): string;
    69     function IsBoxedValue(obj: TSerializedObject; index: integer): boolean;
    70     function GetBoxedValue(obj: TSerializedObject; index: integer): string;
    71     function IsReferenceType(numType: integer; index: integer): boolean;
     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;
     150    function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject;
     151    function GetObject(id: string): TCustomSerializedObject;
     152    function GetObject(id: longword): TCustomSerializedObject;
     153    function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean;
     154    function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string;
    72155    procedure LoadFromStream(Stream: TStream);
    73156    procedure LoadFromFile(filename: string);
    74157    function ToString: string;
    75158    constructor Create;
     159    destructor Destroy; override;
     160    function GetTypeOfClassObject(idObject: longword): integer;
    76161  private
    77162    EndOfStream:      boolean;
    78     ArrayFillerCount: integer;
     163    ArrayFillerCount: Longword;
    79164    currentAutoObjectValue: longword;
    80165    function nextAutoObjectId: longword;
    81166    function LoadNextFromStream(Stream: TStream): longword;
    82167    function LoadStringFromStream(Stream: TStream): string;
     168    function LoadDotNetCharFromStream(Stream: TStream): string;
    83169    function LoadTypeFromStream(Stream: TStream; IsRuntimeType: boolean): integer;
    84170    function LoadValuesFromStream(Stream: TStream; numType: integer): ArrayOfNameValue;
    85     function LoadValueFromStream(Stream: TStream; fieldType: TFieldType): string;
    86     function GetTypeOfObject(idObject: longword): integer;
    87   end;
    88 
     171    function LoadValueFromStream(Stream: TStream; const fieldType: TFieldType): string;
     172    function LoadFieldType(Stream: TStream; category: TTypeCategory): TFieldType;
     173  end;
     174
     175function WinReadByte(stream: TStream): byte;
    89176function WinReadWord(Stream: TStream): word;
    90177function WinReadSmallInt(Stream: TStream): smallint;
    … …  
    119206
    120207{$hints off}
     208
     209function WinReadByte(stream: TStream): byte;
     210begin
     211  stream.Read(Result, sizeof(Result));
     212end;
     213
    121214function WinReadWord(Stream: TStream): word;
    122215begin
    … …  
    155248end;
    156249
    157 {$hints on}
    158 
    159 { TDotNetDeserialization }
    160 
    161 function TDotNetDeserialization.FindObject(typeName: string): PSerializedObject;
    162 var
    163   i, numType:   integer;
    164   comparedType: string;
    165 begin
    166   for i := 0 to high(objects) do
     250function GetFieldTypeSize(const fieldType: TFieldType): longword;
     251begin
     252  case fieldType.category of
     253    ftPrimitiveType:
     254      case fieldType.primitiveType of
     255        ptBoolean, ptByte,ptSByte: result := 1;
     256        ptChar,ptString, ptDecimal: Result := sizeof(string);
     257        ptSingle: result := sizeof(single);
     258        ptDouble: result := sizeof(double);
     259        ptInt16,ptUInt16: result := 2;
     260        ptInt32,ptUInt32: result := 4;
     261        ptInt64,ptUInt64,ptDateTime: result := 8;
     262      else
     263        raise Exception.Create('Unknown primitive type (' + IntToStr(
     264          byte(fieldType.primitiveType)) + ')');
     265      end;
     266    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     267    ftArrayOfString, ftArrayOfPrimitiveType: result := 4;
     268  else
     269    raise Exception.Create('Unknown field type (' + IntToStr(
     270      byte(fieldType.category)) + ')');
     271  end;
     272end;
     273
     274function IsDotNetTypeStoredAsString(const fieldType: TFieldType): boolean;
     275begin
     276  result := (fieldType.category = ftPrimitiveType) and
     277    (fieldType.primitiveType in [ptChar,ptString,ptDecimal]);
     278end;
     279
     280function DotNetValueToString(var value; const fieldType: TFieldType): string;
     281var
     282  tempByte:     byte;
     283  value2bytes: record
     284    case byte of
     285    2: (tempWord: word);
     286    3: (tempInt16: smallint);
     287  end;
     288  value4bytes: record
     289    case byte of
     290    1: (tempSingle:   single);
     291    2: (tempLongWord: longword);
     292    3: (tempLongInt: longint);
     293  end;
     294  value8bytes: record
     295    case byte of
     296    1: (tempDouble:   double);
     297    2: (tempInt64:    Int64);
     298    2: (tempUInt64:   QWord);
     299  end;
     300  tempIdObject: longword;
     301
     302begin
     303  if IsDotNetTypeStoredAsString(fieldType) then
    167304  begin
    168     numType := objects[i].numType;
    169     if numType >= 0 then
    170     begin
    171       comparedType := objectTypes[numType].ClassName;
    172       if (comparedType = typeName) or (length(typeName) <
    173         length(comparedType)) and
    174         (copy(comparedType, length(comparedType) - length(typeName),
    175         length(typeName) + 1) = '.' + typeName) then
    176       begin
    177         Result := @objects[i];
    178         exit;
    179       end;
    180     end;
    181   end;
    182   Result := nil;
    183 end;
    184 
    185 function TDotNetDeserialization.GetSimpleField(obj: TSerializedObject;
    186   Name: string): string;
    187 var
    188   i: integer;
    189 begin
    190   i := FieldIndex(obj, Name);
    191   if i = -1 then
    192     Result := ''
    193   else
    194   begin
    195     if IsBoxedValue(obj, i) then
    196       Result := GetBoxedValue(obj, i)
     305    Result := pstring(@value)^;
     306    exit;
     307  end;
     308  case fieldType.category of
     309    ftPrimitiveType: case fieldType.primitiveType of
     310        ptBoolean:
     311        begin
     312          {$hints off}
     313          move(value,tempByte,sizeof(tempByte));
     314          {$hints on}
     315          if tempByte = 0 then
     316            Result := 'False'
     317          else
     318          if tempByte = 1 then
     319            Result := 'True'
     320          else
     321            raise Exception.Create('Invalid boolean value (' +
     322              IntToStr(tempByte) + ')');
     323        end;
     324        ptByte: Result := inttostr(pbyte(@value)^);
     325        ptSByte: Result := inttostr(pshortint(@value)^);
     326        ptInt16,ptUInt16:
     327        begin
     328          {$hints off}
     329          move(value, value2bytes.tempWord,sizeof(word));
     330          {$hints on}
     331          value2bytes.tempWord := LEtoN(value2bytes.tempWord);
     332          if fieldType.primitiveType = ptInt16 then
     333            Result := IntToStr(value2bytes.tempInt16)
     334          else
     335            Result := IntToStr(value2bytes.tempWord);
     336        end;
     337        ptInt32,ptUInt32,ptSingle:
     338        begin
     339          {$hints off}
     340          move(value, value4bytes.tempLongWord,sizeof(longword));
     341          {$hints on}
     342          value4bytes.tempLongWord := LEtoN(value4bytes.tempLongWord);
     343          if fieldType.primitiveType = ptInt32 then
     344            Result := IntToStr(value4bytes.tempLongInt)
     345          else if fieldType.primitiveType = ptUInt32 then
     346            Result := IntToStr(value4bytes.tempLongWord)
     347          else
     348            result := FloatToStr(value4bytes.tempSingle);
     349        end;
     350
     351        ptInt64,ptUInt64,ptDouble,ptDateTime:
     352        begin
     353          {$hints off}
     354          move(value, value8bytes.tempUInt64,8);
     355          {$hints on}
     356          value8bytes.tempUInt64 := LEtoN(value8bytes.tempUInt64);
     357          if fieldType.primitiveType = ptInt64 then
     358            Result := IntToStr(value8bytes.tempInt64)
     359          else if fieldType.primitiveType = ptUInt64 then
     360            Result := IntToStr(value8bytes.tempUInt64)
     361          else if fieldType.primitiveType = ptDouble then
     362            result := FloatToStr(value8bytes.tempDouble)
     363          else
     364            Result := DateTimeToStr(
     365            (value8bytes.tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
     366        end;
     367        else
     368          raise Exception.Create('Unknown primitive type (' + IntToStr(
     369            byte(fieldType.primitiveType)) + ')');
     370      end;
     371    ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     372    ftArrayOfString, ftArrayOfPrimitiveType:
     373    begin
     374      {$hints off}
     375      move(value,tempIdObject,sizeof(tempIdObject));
     376      {$hints on}
     377      result := '#' + IntToStr(tempIdObject);
     378    end;
    197379    else
    198       Result := obj.fields[i].Value;
    199   end;
    200 end;
    201 
    202 function TDotNetDeserialization.FieldIndex(obj: TSerializedObject;
    203   Name: string): integer;
    204 var
    205   i: integer;
    206 begin
    207   //case sensitive
    208   for i := 0 to high(obj.fields) do
    209     if obj.fields[i].Name = Name then
    210     begin
    211       Result := i;
    212       exit;
    213     end;
    214   //case insensitive
    215   for i := 0 to high(obj.fields) do
    216     if compareText(obj.fields[i].Name, Name) = 0 then
    217     begin
    218       Result := i;
    219       exit;
    220     end;
    221   //case sensitive inner member
    222   for i := 0 to high(obj.fields) do
    223     if (length(Name) < length(obj.fields[i].Name)) and
    224       (copy(obj.fields[i].Name, length(obj.fields[i].Name) - length(Name),
    225       length(Name) + 1) = '+' + Name) then
    226     begin
    227       Result := i;
    228       exit;
    229     end;
    230   //case insensitive inner member
    231   for i := 0 to high(obj.fields) do
    232     if (length(Name) < length(obj.fields[i].Name)) and
    233       (compareText(copy(obj.fields[i].Name, length(obj.fields[i].Name) -
    234       length(Name), length(Name) + 1), '+' + Name) = 0) then
    235     begin
    236       Result := i;
    237       exit;
    238     end;
    239   Result := -1;
    240 end;
    241 
    242 function TDotNetDeserialization.GetObjectField(obj: TSerializedObject;
    243   Name: string): PSerializedObject;
    244 var
    245   i: integer;
    246 begin
    247   i := FieldIndex(obj, Name);
    248   if i = -1 then
    249     Result := nil
    250   else
    251   begin
    252     if not IsReferenceType(obj.numType, i) then
    253       raise Exception.Create('GetObjectMember: Not a reference type');
    254     Result := GetObject(obj.fields[i].Value);
    255   end;
    256 end;
    257 
    258 function TDotNetDeserialization.GetObject(id: string): PSerializedObject;
    259 var
    260   idObj: longword;
    261 begin
    262   if copy(id, 1, 1) = '#' then
    263     Delete(id, 1, 1);
    264   idObj  := StrToInt(id);
    265   Result := GetObject(idObj);
    266 end;
    267 
    268 function TDotNetDeserialization.GetObject(id: longword): PSerializedObject;
    269 var
    270   i: integer;
    271 begin
    272   for i := 0 to high(objects) do
    273     if objects[i].idObject = id then
    274     begin
    275       Result := @objects[i];
    276       exit;
    277     end;
    278   Result := nil;
    279 end;
    280 
    281 function TDotNetDeserialization.GetObjectType(obj: PSerializedObject): string;
    282 begin
    283   if (obj^.numType = -btString) then
    284     Result := 'String'
    285   else
    286   if (obj^.numType = -btArrayOfObject) then
    287     Result := 'Object[]'
    288   else
    289   if (obj^.numType = -btArrayOfString) then
    290     Result := 'String[]'
    291   else
    292   if (obj^.numType < 0) or (obj^.numType > high(objectTypes)) then
    293     Result := ''
    294   else
    295   begin
    296     Result := objectTypes[obj^.numType].ClassName;
    297   end;
    298 end;
    299 
    300 function TDotNetDeserialization.PrimitiveTypeName(pt: TPrimitiveType): string;
     380      raise Exception.Create('Unknown field type (' + IntToStr(
     381        byte(fieldType.category)) + ')');
     382  end;
     383end;
     384
     385function PrimitiveTypeName(pt: TPrimitiveType): string;
    301386begin
    302387  case pt of
    … …  
    317402    ptString: Result   := 'String';
    318403    else
    319       raise Exception.Create('Unknown primitive type (' + IntToStr(byte(pt)) + ')');
    320   end;
    321 end;
    322 
    323 function TDotNetDeserialization.IsBoxedValue(obj: TSerializedObject;
     404      raise Exception.Create('Unknown primitive type (' + IntToStr(integer(pt)) + ')');
     405  end;
     406end;
     407
     408Function DotNetTypeToString(ft: TFieldType): string;
     409begin
     410  if ft.category = ftPrimitiveType then
     411    result := PrimitiveTypeName(ft.primitiveType)
     412  else
     413    case ft.category of
     414      ftString: result := 'String';
     415      ftObjectType: result := 'Object';
     416      ftRuntimeType: result := 'RuntimeType';
     417      ftGenericType: result := 'GenericType';
     418      ftArrayOfObject: result := 'Object[]';
     419      ftArrayOfString: result := 'String[]';
     420      ftArrayOfPrimitiveType: result := 'PrimitiveType[]';
     421    else
     422      raise Exception.Create('Unknown field type (' + IntToStr(
     423        byte(ft.category)) + ')');
     424    end;
     425end;
     426
     427{ TCustomSerializedObject }
     428
     429function TCustomSerializedObject.GetFieldAsString(Name: string): string;
     430begin
     431  result := GetFieldAsString(GetFieldIndex(Name));
     432end;
     433
     434constructor TCustomSerializedObject.Create(container: TDotNetDeserialization);
     435begin
     436  FContainer := container;
     437  refCount := 0;
     438end;
     439
     440function TCustomSerializedObject.GetFieldIndex(Name: string): integer;
     441var
     442  i: integer;
     443  fn: string;
     444begin
     445  if FieldCount = 0 then
     446  begin
     447    result := -1;
     448    exit;
     449  end;
     450  //case sensitive
     451  for i := 0 to FieldCount-1 do
     452    if FieldName[i] = Name then
     453    begin
     454      Result := i;
     455      exit;
     456    end;
     457  //case insensitive
     458  for i := 0 to FieldCount-1 do
     459    if compareText(FieldName[i], Name) = 0 then
     460    begin
     461      Result := i;
     462      exit;
     463    end;
     464  //case sensitive inner member
     465  for i := 0 to FieldCount-1 do
     466  begin
     467    fn := FieldName[i];
     468    if (length(Name) < length(fn)) and
     469      (copy(fn, length(fn) - length(Name),
     470      length(Name) + 1) = '+' + Name) then
     471    begin
     472      Result := i;
     473      exit;
     474    end;
     475  end;
     476  //case insensitive inner member
     477  for i := 0 to FieldCount-1 do
     478  begin
     479    fn := FieldName[i];
     480    if (length(Name) < length(fn)) and
     481      (compareText(copy(fn, length(fn) -
     482      length(Name), length(Name) + 1), '+' + Name) = 0) then
     483    begin
     484      Result := i;
     485      exit;
     486    end;
     487  end;
     488  Result := -1;
     489end;
     490
     491{ TSerializedClass }
     492
     493function TSerializedClass.GetFieldAsString(Index: longword): string;
     494begin
     495  result := fields[Index].Value;
     496end;
     497
     498function TSerializedClass.GetFieldCount: longword;
     499begin
     500  Result:= length(fields);
     501end;
     502
     503function TSerializedClass.GetFieldName(Index: longword): string;
     504begin
     505  result := fields[Index].Name;
     506end;
     507
     508function TSerializedClass.GetFieldTypeAsString(Index: longword): string;
     509begin
     510  result := fields[Index].valueType;
     511end;
     512
     513function TSerializedClass.IsReferenceType(index: longword): boolean;
     514begin
     515  Result:= FContainer.objectTypes[numType].fieldTypes[index].category <> ftPrimitiveType;
     516end;
     517
     518function TSerializedClass.GetTypeAsString: string;
     519begin
     520  Result:= FContainer.objectTypes[numType].ClassName;
     521end;
     522
     523{ TSerializedArray }
     524
     525procedure TSerializedArray.InitData;
     526begin
     527  FItemSize := GetFieldTypeSize(itemType);
     528  getmem(data, itemSize*nbItems);
     529  fillchar(data^, itemSize*nbItems, 0);
     530end;
     531
     532function TSerializedArray.GetItemPtr(Index: longword): pointer;
     533begin
     534  if index >= nbItems then
     535    raise exception.Create('Index out of bounds');
     536  result := pointer(pbyte(data)+Index*itemsize);
     537end;
     538
     539function TSerializedArray.GetFieldAsString(Index: longword): string;
     540begin
     541  if data = nil then
     542    result := ''
     543  else
     544    result := DotNetValueToString(ItemPtr[index]^, itemType);
     545end;
     546
     547function TSerializedArray.GetFieldCount: longword;
     548begin
     549  Result:= nbItems;
     550end;
     551
     552function TSerializedArray.GetFieldName(Index: longword): string;
     553var
     554  r: longword;
     555begin
     556  result := '[';
     557  for r := 1 to length(dimensions) do
     558  begin
     559    if r <> 1 then result+=',';
     560    result += inttostr(index mod dimensions[r-1]);
     561    index := index div dimensions[r-1];
     562  end;
     563  result += ']';
     564end;
     565
     566{$hints off}
     567function TSerializedArray.GetFieldTypeAsString(Index: longword): string;
     568begin
     569  Result:= DotNetTypeToString(itemType);
     570end;
     571{$hints on}
     572
     573{$hints off}
     574function TSerializedArray.IsReferenceType(index: longword): boolean;
     575begin
     576  Result:= itemType.category <> ftPrimitiveType;
     577end;
     578{$hints on}
     579
     580function TSerializedArray.GetTypeAsString: string;
     581var
     582  i: Integer;
     583begin
     584  Result:= DotNetTypeToString(itemType)+'[';
     585  for i := 2 to length(dimensions) do
     586    result += ',';
     587  result += ']';
     588end;
     589
     590constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword);
     591begin
     592  inherited Create(AContainer);
     593  setlength(dimensions,1);
     594  dimensions[0] := ALength;
     595  nbItems := ALength;
     596  FArrayType := gatSingleDimension;
     597  itemType := AItemType;
     598  InitData;
     599end;
     600
     601constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType;
     602  ADimensions: arrayOfLongword);
     603var n: longword;
     604begin
     605  inherited Create(AContainer);
     606  setlength(dimensions, length(ADimensions));
     607  nbItems := 1;
     608  if length(ADimensions) <> 0 then
     609    for n := 0 to length(ADimensions)-1 do
     610    begin
     611      dimensions[n] := ADimensions[n];
     612      nbItems *= ADimensions[n];
     613    end;
     614  FArrayType := AArrayType;
     615  itemType := AItemType;
     616  InitData;
     617end;
     618
     619destructor TSerializedArray.Destroy;
     620var ps: PString;
     621  n: longword;
     622begin
     623  if IsDotNetTypeStoredAsString(itemType) and (nbItems <> 0) then
     624  begin
     625    ps := PString(data);
     626    for n := 1 to nbItems do
     627    begin
     628      ps^ := '';
     629      inc(ps);
     630    end;
     631  end;
     632  freemem(data);
     633  inherited Destroy;
     634end;
     635
     636{ TSerializedValue }
     637
     638function TSerializedValue.GetIsReferenceType: boolean;
     639begin
     640  result := inherited IsReferenceType(0);
     641end;
     642
     643function TSerializedValue.GetValueAsString: string;
     644begin
     645  result := GetFieldAsString(0);
     646end;
     647
     648function TSerializedValue.GetTypeAsString: string;
     649begin
     650  Result:= GetFieldTypeAsString(0);
     651end;
     652
     653constructor TSerializedValue.Create(AContainer: TDotNetDeserialization;
     654  AItemType: TFieldType);
     655begin
     656  inherited Create(AContainer,AItemType,1);
     657end;
     658
     659{$hints on}
     660
     661{ TDotNetDeserialization }
     662
     663function TDotNetDeserialization.FindClass(typeName: string): TSerializedClass;
     664var obj: TCustomSerializedObject;
     665begin
     666  obj := FindObject(typeName);
     667  if obj is TSerializedClass then
     668    result := obj as TSerializedClass
     669  else
     670    raise exception.Create('FindClass: found object is not a class');
     671end;
     672
     673function TDotNetDeserialization.FindObject(typeName: string): TCustomSerializedObject;
     674var
     675  i:   integer;
     676  comparedType: string;
     677begin
     678  for i := 0 to high(objects) do
     679  begin
     680    comparedType := objects[i].TypeAsString;
     681    if (comparedType = typeName) or
     682      ( (length(typeName) < length(comparedType) ) and
     683        (copy(comparedType, length(comparedType) - length(typeName),
     684        length(typeName) + 1) = '.' + typeName) ) then
     685    begin
     686      Result := objects[i];
     687      exit;
     688    end;
     689  end;
     690  Result := nil;
     691end;
     692
     693function TDotNetDeserialization.GetSimpleField(obj: TCustomSerializedObject;
     694  Name: string): string;
     695var
     696  i,idxSlash: integer;
     697  tempSub: TCustomSerializedObject;
     698begin
     699  i := obj.GetFieldIndex(Name);
     700  if i = -1 then
     701  begin
     702    idxSlash := pos('\',name);
     703    if idxSlash <> 0 then
     704    begin
     705      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
     706      if tempSub <> nil then
     707      begin
     708        result := GetSimpleField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
     709        exit;
     710      end;
     711    end;
     712    Result := ''
     713  end
     714  else
     715  begin
     716    if IsBoxedValue(obj, i) then
     717      Result := GetBoxedValue(obj, i)
     718    else
     719      Result := obj.FieldAsString[i];
     720  end;
     721end;
     722
     723function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
     724  Name: string): TCustomSerializedObject;
     725var
     726  i: integer;
     727  idxSlash: LongInt;
     728  tempSub: TCustomSerializedObject;
     729begin
     730  i := obj.GetFieldIndex(Name);
     731  if i = -1 then
     732  begin
     733    idxSlash := pos('\',name);
     734    if idxSlash <> 0 then
     735    begin
     736      tempSub := GetObjectField(obj,copy(name,1,idxSlash-1));
     737      if tempSub <> nil then
     738      begin
     739        result := GetObjectField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash));
     740        exit;
     741      end;
     742    end;
     743    Result := nil
     744  end
     745  else
     746  begin
     747    if not obj.IsReferenceType(i) then
     748      raise Exception.Create('GetObjectField: Not a reference type');
     749    Result := GetObject(obj.FieldAsString[i]);
     750  end;
     751end;
     752
     753function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject;
     754  index: integer): TCustomSerializedObject;
     755begin
     756  if not obj.IsReferenceType(index) then
     757    raise Exception.Create('GetObjectField: Not a reference type');
     758  Result := GetObject(obj.FieldAsString[index]);
     759end;
     760
     761function TDotNetDeserialization.GetObject(id: string): TCustomSerializedObject;
     762var
     763  idObj: longword;
     764begin
     765  if copy(id, 1, 1) = '#' then
     766    Delete(id, 1, 1);
     767  idObj  := StrToInt64(id);
     768  Result := GetObject(idObj);
     769end;
     770
     771function TDotNetDeserialization.GetObject(id: longword): TCustomSerializedObject;
     772var
     773  i: integer;
     774begin
     775  for i := 0 to high(objects) do
     776    if objects[i].idObject = id then
     777    begin
     778      Result := objects[i];
     779      exit;
     780    end;
     781  Result := nil;
     782end;
     783
     784function TDotNetDeserialization.IsBoxedValue(obj: TCustomSerializedObject;
    324785  index: integer): boolean;
    325786var
    326   subObj: PSerializedObject;
    327 begin
    328   if not IsReferenceType(obj.numType, index) then
     787  subObj: TCustomSerializedObject;
     788begin
     789  if not obj.IsReferenceType(index) then
    329790  begin
    330791    Result := False;
    331792    exit;
    332793  end;
    333   subObj := GetObject(obj.fields[index].Value);
    334   if subObj = nil then
     794  subObj := GetObject(obj.FieldAsString[index]);
     795  if subObj = nil then //suppose Nothing is a boxed value
    335796  begin
    336797    Result := True;
    337798    exit;
    338799  end;
    339   Result := (length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '');
    340 end;
    341 
    342 function TDotNetDeserialization.GetBoxedValue(obj: TSerializedObject;
     800  Result := subObj is TSerializedValue;
     801end;
     802
     803function TDotNetDeserialization.GetBoxedValue(obj: TCustomSerializedObject;
    343804  index: integer): string;
    344805var
    345   subObj: PSerializedObject;
    346 begin
    347   if not IsReferenceType(obj.numType, index) then
     806  subObj: TCustomSerializedObject;
     807begin
     808  if not obj.IsReferenceType(index) then
    348809    raise Exception.Create('GetBoxedValue: Not a reference type');
    349   subObj := GetObject(obj.fields[index].Value);
     810  subObj := GetObject(obj.FieldAsString[index]);
    350811  if subObj = nil then
    351812  begin
    … …  
    353814    exit;
    354815  end;
    355   if (length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '') then
    356     Result := subObj^.fields[0].Value
     816  if (subObj is TSerializedValue) and not (subObj as TSerializedValue).IsReferenceType then
     817    Result := (subObj as TSerializedValue).ValueAsString
    357818  else
    358819    raise Exception.Create('GetBoxedValue: Not a primitive type');
    359 end;
    360 
    361 function TDotNetDeserialization.IsReferenceType(numType: integer;
    362   index: integer): boolean;
    363 begin
    364   if numType >= length(objectTypes) then
    365     raise Exception.Create('IsReferenceType: Type number out of bounds');
    366 
    367   if (numType < 0) then
    368   begin
    369     Result := (numType = -btArrayOfObject) or (numtype = -btArrayOfString);
    370   end
    371   else
    372   begin
    373     if (index < 0) or (index >= objecttypes[numType].nbFields) then
    374       raise Exception.Create('IsReferenceType: Index out of bounds');
    375 
    376     Result := (objecttypes[numType].fieldTypes[index].category <> ftPrimitiveType);
    377   end;
    378820end;
    379821
    … …  
    433875    subNum: integer;
    434876    objType, subExpectedType: string;
     877    fieldTypeStr: string;
    435878  begin
    436879    Result := '';
    … …  
    448891      end;
    449892      inToString := True;
     893      objType := TypeAsString;
    450894      if main then
    451895      begin
    452         if numType < 0 then
    453           objType := ''
    454         else
    455           objType := objectTypes[numType].ClassName;
    456896        Result += tab + 'Object';
    457         if refCount > 0 then
    458           Result += ' #' + IntToStr(idObject);
     897        Result += ' #' + IntToStr(idObject);
    459898        if (objType = '') or (objType = expectedType) then
    460899          Result += ' = '
    … …  
    464903      else
    465904      begin
    466         objType := GetObjectType(@objects[num]);
    467905        if (objType = '') or (objType = expectedType) then
    468906          Result := ''
    … …  
    477915        subExpectedType := '';
    478916
    479       if not main and (length(fields) = 1) and (fields[0].Name = '') then
     917      if not main and (objects[num] is TSerializedValue) then
    480918      begin
    481         Result += fields[0].Value + LineEnding;
     919        Result += (objects[num] as TSerializedValue).ValueAsString + LineEnding;
    482920      end
    483921      else
    484       if (length(fields) = 0) then
     922      if (FieldCount = 0) then
    485923      begin
    486924        Result += '{}' + LineEnding;
    … …  
    489927      begin
    490928        Result += '{' + LineEnding;
    491         for j := 0 to High(fields) do
     929        for j := 0 to FieldCount-1 do
    492930        begin
    493           Result += tab + '  ' + fields[j].Name;
    494           if (fields[j].valueType <> '') and (fields[j].valueType <> subExpectedType) and
    495             not ((subExpectedType = '') and ((fields[j].valueType = 'Int32') or
    496             (fields[j].valueType = 'Boolean'))) then
    497             Result += ' As ' + fields[j].valueType;
     931          Result += tab + '  ' + FieldName[j];
     932          fieldTypeStr := FieldTypeAsString[j];
     933          if (fieldTypeStr <> '') and (fieldTypeStr <> subExpectedType) and
     934            not ((subExpectedType = '') and ((fieldTypeStr = 'Int32') or
     935            (fieldTypeStr = 'Boolean') or (fieldTypeStr = 'Double'))) then
     936            Result += ' As ' + fieldTypeStr;
    498937          Result   += ' = ';
    499           if not IsReferenceType(numType, j) or (copy(fields[j].Value, 1, 1) <> '#') or
    500             (fields[j].Value = '#0') then
    501             Result += fields[j].Value + lineending
     938          if not IsReferenceType(j) then
     939            Result += FieldAsString[j] + lineending
    502940          else
    503941          begin
    504             subId  := StrToInt(copy(fields[j].Value, 2, length(fields[j].Value) - 1));
    505             subNum := -1;
    506             for k := 0 to high(objects) do
    507               if (objects[k].idObject = subId) then
     942            try
     943              subId  := StrToInt64(copy(fieldAsString[j], 2, length(fieldAsString[j]) - 1));
     944              if subId = 0 then result += 'null'+LineEnding else
    508945              begin
    509                 subNum := k;
    510                 break;
     946                begin
     947                  subNum := -1;
     948                  for k := 0 to high(objects) do
     949                  if (objects[k].idObject = subId) then
     950                  begin
     951                    subNum := k;
     952                    break;
     953                  end;
     954                end;
     955                if subNum = -1 then
     956                  Result += '(Not found) #' + IntToStr(subId)+LineEnding
     957                else
     958                  Result += objectToString(subNum, fieldTypeStr, tab + '  ', False);
    511959              end;
    512             if subNum = -1 then
    513               Result += '#' + IntToStr(subId) + '!' + LineEnding
    514             else
    515               Result += objectToString(subNum, fields[j].valueType, tab + '  ', False);
     960            except
     961              result += '!' + fieldAsString[j]+'!' +LineEnding
     962            end;
    516963          end;
    517964        end;
    … …  
    541988end;
    542989
     990destructor TDotNetDeserialization.Destroy;
     991var
     992  i: Integer;
     993begin
     994  for i := 0 to high(objects) do
     995    objects[i].Free;
     996  inherited Destroy;
     997end;
     998
     999function TDotNetDeserialization.GetTypeOfClassObject(idObject: longword
     1000  ): integer;
     1001var
     1002  i: Integer;
     1003begin
     1004  for i := 0 to high(objects) do
     1005    if objects[i].idObject = idObject then
     1006    begin
     1007      if objects[i] is TSerializedClass then
     1008      begin
     1009        result := (objects[i] as TSerializedClass).numType;
     1010        exit;
     1011      end
     1012      else
     1013        raise exception.Create('GetTypeOfClassObject: Specified object is not of class type');
     1014    end;
     1015  raise exception.Create('GetTypeOfClassObject: Object not found');
     1016end;
     1017
    5431018function TDotNetDeserialization.nextAutoObjectId: longword;
    5441019begin
    … …  
    5521027  idRefObject, tempIdObject: longword;
    5531028  tempType:     TFieldType;
    554   arrayCount, i, idx, FillZeroCount: integer;
    555   tempObj:      TSerializedObject;
    556   tempTypeName: string;
    557   tempPObj:     PSerializedObject;
     1029  arrayCount, arrayIndex,FillZeroCount : longword;
     1030  tempAnyObj: TCustomSerializedObject;
     1031  newClassObj: TSerializedClass;
     1032  newValueObj: TSerializedValue;
     1033  newArrayObj: TSerializedArray;
     1034  genericArrayType: TGenericArrayType;
     1035  genericArrayRank: longword;
     1036  genericArrayDims: array of longword;
     1037  genericArrayItemType: TFieldType;
     1038
     1039  function GetArrayCellNumber(index: longword): string;
     1040  var r: longword;
     1041  begin
     1042    result := '';
     1043    for r := 1 to genericArrayRank do
     1044    begin
     1045      if r <> 1 then result+=',';
     1046      result += inttostr(index mod genericArrayDims[r-1]);
     1047      index := index div genericArrayDims[r-1];
     1048    end;
     1049  end;
     1050
    5581051begin
    5591052  Result := 0; //idObject or zero
    560    {$hints off}
    561   Stream.Read(blockType, sizeof(blockType));
    562    {$hints on}
     1053  blockType := WinReadByte(Stream);
    5631054  case blockType of
    5641055
    … …  
    5681059      with assemblies[high(assemblies)] do
    5691060      begin
    570         Stream.Read(idAssembly, 4);
     1061        idAssembly := WinReadLongword(Stream);
    5711062        Name := LoadStringFromStream(Stream);
    5721063      end;
    … …  
    5751066    btRuntimeObject, btExternalObject:
    5761067    begin
     1068      newClassObj := TSerializedClass.Create(self);
    5771069      setlength(objects, length(objects) + 1);
    578       idx := high(objects);
    579       with tempObj do  //use temp because array address may change
     1070      objects[high(objects)] := newClassObj;
     1071      with newClassObj do
    5801072      begin
    581         refCount := 0;
    582         Stream.Read(idObject, 4);
    583         Result  := idObject;
    584         numType := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
    585       end;
    586       objects[idx]   := tempObj;
    587       tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType);
    588       objects[idx].fields := tempObj.fields;
     1073        idObject := WinReadLongword(Stream);
     1074        Result   := idObject;
     1075        numType  := LoadTypeFromStream(Stream, blockType = btRuntimeObject);
     1076        fields   := LoadValuesFromStream(Stream, numType);
     1077      end;
    5891078    end;
    5901079
    5911080    btRefTypeObject:
    5921081    begin
     1082      newClassObj := TSerializedClass.Create(self);
    5931083      setlength(objects, length(objects) + 1);
    594       idx := high(objects);
    595       with tempObj do  //use temp because array address may change
     1084      objects[high(objects)] := newClassObj;
     1085      with newClassObj do
    5961086      begin
    597         refCount    := 0;
    5981087        idObject    := WinReadLongword(Stream);
    5991088        Result      := idObject;
    6001089        idRefObject := WinReadLongword(Stream);
    601         numType     := GetTypeOfObject(idRefObject);
    602       end;
    603       objects[idx]   := tempObj;
    604       tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType);
    605       objects[idx].fields := tempObj.fields;
     1090        numType     := GetTypeOfClassObject(idRefObject);
     1091        fields      := LoadValuesFromStream(Stream, numType);
     1092      end;
    6061093    end;
    6071094
    6081095    btString:
    6091096    begin
     1097      tempType.primitiveType := ptString;
     1098      tempType.category := ftPrimitiveType;
     1099      tempType.Name := PrimitiveTypeName(ptString);
     1100      tempType.refAssembly := 0;
     1101
     1102      newValueObj := TSerializedValue.Create(self,tempType);
    6101103      setlength(objects, length(objects) + 1);
    611       idx := high(objects);
    612       with tempObj do  //use temp because array address may change
     1104      objects[high(objects)] := newValueObj;
     1105      with newValueObj do
    6131106      begin
    614         refCount := 0;
    615         Stream.Read(idObject, 4);
     1107        idObject := WinReadLongword(Stream);
    6161108        Result  := idObject;
    617         numType := -blockType;
    618         setlength(fields, 1);
    619         fields[0].Name      := '';
    620         fields[0].valueType := 'String';
    621         fields[0].Value     := LoadStringFromStream(Stream);
    622       end;
    623       objects[idx] := tempObj;
     1109        pstring(data)^ := LoadStringFromStream(Stream);
     1110      end;
    6241111    end;
    6251112
    … …  
    6271114    begin
    6281115      try
     1116        tempType.category    := ftPrimitiveType;
     1117        tempType.refAssembly := 0;
     1118        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
     1119        tempType.Name := PrimitiveTypeName(tempType.primitiveType);
     1120
     1121        newValueObj := TSerializedValue.Create(self,tempType);
    6291122        setlength(objects, length(objects) + 1);
    630         idx := high(objects);
    631         with tempObj do  //use temp because array address may change
     1123        objects[high(objects)] := newValueObj;
     1124
     1125        with newValueObj do
    6321126        begin
    633           refCount := 0;
    6341127          idObject := nextAutoObjectId;
    6351128          Result   := idObject;
    636           numType  := -blockType;
    637 
    638           tempType.category    := ftPrimitiveType;
    639           tempType.refAssembly := 0;
    640           Stream.Read(tempType.primitiveType, 1);
    641           tempType.Name := PrimitiveTypeName(tempType.primitiveType);
    642 
    643           setlength(fields, 1);
    644           fields[0].Name      := '';
    645           fields[0].Value     := LoadValueFromStream(Stream, tempType);
    646           fields[0].valueType := tempType.Name;
     1129
     1130          if IsDotNetTypeStoredAsString(tempType) then
     1131            pstring(data)^ := LoadValueFromStream(Stream, tempType)
     1132          else
     1133            Stream.Read(data^, itemSize);
    6471134        end;
    648         objects[idx] := tempObj;
    6491135      except
    6501136        on ex: Exception do
    … …  
    6561142    btObjectReference:
    6571143    begin
    658       Stream.Read(Result, 4);
    659       tempPObj := GetObject(Result);
    660       if tempPObj <> nil then
    661         Inc(tempPObj^.refCount);
     1144      result := WinReadLongword(Stream);
     1145      tempAnyObj := GetObject(Result);
     1146      if tempAnyObj <> nil then
     1147        Inc(tempAnyObj.refCount);
    6621148    end;
    6631149
    … …  
    6671153    begin
    6681154      try
     1155        result := WinReadLongword(Stream);
     1156        arrayCount := WinReadLongword(Stream);
     1157
     1158        tempType.category    := ftPrimitiveType;
     1159        tempType.refAssembly := 0;
     1160        tempType.primitiveType := TPrimitiveType(WinReadByte(stream));
     1161        tempType.Name := PrimitiveTypeName(tempType.primitiveType);
     1162
     1163        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
    6691164        setlength(objects, length(objects) + 1);
    670         idx := high(objects);
    671         with tempObj do  //use temp because array address may change
     1165        objects[high(objects)] := newArrayObj;
     1166        with newArrayObj do
    6721167        begin
    673           refCount := 0;
    674           Stream.Read(idObject, 4);
    675           Result     := idObject;
    676           arrayCount := WinReadLongint(Stream);
    677 
    678           tempType.category    := ftPrimitiveType;
    679           tempType.refAssembly := 0;
    680           Stream.Read(tempType.primitiveType, 1);
    681           tempType.Name := PrimitiveTypeName(tempType.primitiveType);
    682 
    683           setlength(fields, arrayCount);
    684           for i := 0 to arrayCount - 1 do
     1168          idObject := result;
     1169
     1170          if arrayCount <> 0 then
    6851171          begin
    686             fields[i].Name      := '[' + IntToStr(i) + ']';
    687             fields[i].Value     := LoadValueFromStream(Stream, tempType);
    688             fields[i].valueType := tempType.Name;
    689           end;
    690 
    691           setlength(objectTypes, length(objecttypes) + 1);
    692           numType := high(objectTypes);
    693           with objectTypes[numType] do
    694           begin
    695             ClassName := tempType.Name + '[]';
    696             nbFields  := arrayCount;
    697             setlength(fieldNames, nbFields);
    698             setlength(fieldTypes, nbFields);
    699             for i := 0 to arrayCount - 1 do
     1172            if IsDotNetTypeStoredAsString(tempType) then
    7001173            begin
    701               fieldNames[i] := fields[i].Name;
    702               fieldTypes[i] := tempType;
     1174              for arrayIndex := 0 to arrayCount - 1 do
     1175                pstring(ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream, tempType);
     1176            end else
     1177            begin
     1178              for arrayIndex := 0 to arrayCount - 1 do
     1179                stream.Read(ItemPtr[arrayIndex]^, itemSize);
    7031180            end;
    704             refAssembly := 0;
    7051181          end;
    7061182        end;
    707         objects[idx] := tempObj;
    7081183      except
    7091184        on ex: Exception do
    … …  
    7131188    end;
    7141189
    715     btArrayOfObject, btArrayOfString:
     1190    btArrayOfObject,btArrayOfString:
    7161191    begin
    7171192      try
     1193        result := WinReadLongword(Stream);
     1194        arrayCount := WinReadLongword(Stream);
     1195
     1196        if blockType = btArrayOfObject then
     1197          tempType.category := ftObjectType
     1198        else
     1199          tempType.category := ftString;
     1200
     1201        tempType.refAssembly := 0;
     1202        tempType.primitiveType := ptNone;
     1203        tempType.Name := DotNetTypeToString(tempType);
     1204
     1205        newArrayObj := TSerializedArray.Create(self,tempType,arrayCount);
    7181206        setlength(objects, length(objects) + 1);
    719         idx := high(objects);
    720         with tempObj do  //use temp because array address may change
     1207        objects[high(objects)] := newArrayObj;
     1208
     1209        with newArrayObj do
    7211210        begin
    722           refCount := 0;
    723           Stream.Read(idObject, 4);
    724           Result  := idObject;
    725           numType := -blockType;
    726           Stream.Read(arrayCount, 4);
    727         end;
    728         objects[idx] := tempObj;
    729         with tempObj do
    730         begin
    731           setlength(fields, arrayCount);
     1211          idObject:= result;
    7321212          FillZeroCount := 0;
    733           if blockType = btArrayOfObject then
    734             tempTypeName := 'Object'
    735           else
    736             tempTypeName := 'String';
    737           for i := 0 to arrayCount - 1 do
    738           begin
    739             fields[i].Name      := '[' + IntToStr(i) + ']';
    740             fields[i].valueType := tempTypeName;
    741             if FillZeroCount > 0 then
     1213          if arrayCount <> 0 then
     1214            for arrayIndex := 0 to arrayCount - 1 do
    7421215            begin
    743               fields[i].Value := '#0';
    744               Dec(FillZeroCount);
    745             end
    746             else
    747             begin
    748               tempIdObject := LoadNextFromStream(Stream);
    749               if tempIdObject = idArrayFiller then
    750               begin
    751                 tempIdObject     := 0;
    752                 FillZeroCount    := ArrayFillerCount;
    753                 ArrayFillerCount := 0;
    754               end;
    7551216              if FillZeroCount > 0 then
    756               begin
    757                 fields[i].Value := '#0';
    758                 Dec(FillZeroCount);
    759               end
     1217                Dec(FillZeroCount)
    7601218              else
    7611219              begin
    762                 fields[i].Value := '#' + IntToStr(tempIdObject);
     1220                tempIdObject := LoadNextFromStream(Stream);
     1221                if tempIdObject = idArrayFiller then
     1222                begin
     1223                  tempIdObject     := 0;
     1224                  FillZeroCount    := ArrayFillerCount;
     1225                  ArrayFillerCount := 0;
     1226                end;
     1227                if FillZeroCount > 0 then
     1228                  Dec(FillZeroCount)
     1229                else
     1230                  plongword(ItemPtr[arrayIndex])^ := tempIdObject;
    7631231              end;
    7641232            end;
    765           end;
    7661233        end;
    767         objects[idx].fields := tempObj.fields;
    7681234      except
    7691235        on ex: Exception do
    … …  
    7771243      arrayCount := 0;
    7781244      if blockType = btArrayFiller8b then
    779       begin
    780         Stream.Read(arrayCount, 1);
    781       end
     1245        arrayCount := WinReadByte(Stream)
    7821246      else
    783         Stream.Read(arrayCount, 3);
    784       arrayCount := LEtoN(arrayCount);
     1247        arrayCount := WinReadLongWord(Stream);
    7851248      ArrayFillerCount := arraycount;
    7861249    end;
    7871250
    7881251    btGenericArray:
    789       raise Exception.Create('Generic array not supported');
     1252    begin
     1253        try
     1254          result := WinReadLongword(Stream);
     1255          genericArrayType := TGenericArrayType( WinReadByte(Stream) );
     1256          genericArrayRank := WinReadLongword(Stream);
     1257          setlength(genericArrayDims,genericArrayRank);
     1258          arrayCount := 0;
     1259          if genericArrayRank <> 0 then
     1260            for arrayIndex := 0 to genericArrayRank-1 do
     1261            begin
     1262              genericArrayDims[arrayIndex] := WinReadLongword(Stream);
     1263              if arrayIndex=0 then
     1264                arrayCount := genericArrayDims[arrayIndex]
     1265              else
     1266                arrayCount *= genericArrayDims[arrayIndex];
     1267            end;
     1268          genericArrayItemType.category := TTypeCategory(WinReadByte(Stream));
     1269          genericArrayItemType := LoadFieldType(stream,genericArrayItemType.category);
     1270
     1271          newArrayObj := TSerializedArray.Create(self,genericArrayType,genericArrayItemType,genericArrayDims);
     1272          setlength(objects, length(objects) + 1);
     1273          objects[high(objects)] := newArrayObj;
     1274          newArrayObj.idObject := result;
     1275
     1276          FillZeroCount := 0;
     1277          if arrayCount <> 0 then
     1278            for arrayIndex := 0 to arrayCount - 1 do
     1279            begin
     1280              if IsDotNetTypeStoredAsString(genericArrayItemType) then
     1281                PString(newArrayObj.ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream,genericArrayItemType)
     1282              else
     1283              if genericArrayItemType.category = ftPrimitiveType then
     1284                Stream.Read(newArrayObj.ItemPtr[arrayIndex]^, newArrayObj.ItemSize)
     1285              else
     1286              begin
     1287                if FillZeroCount > 0 then
     1288                  Dec(FillZeroCount)
     1289                else
     1290                begin
     1291                  tempIdObject := LoadNextFromStream(Stream);
     1292                  if tempIdObject = idArrayFiller then
     1293                  begin
     1294                    tempIdObject     := 0;
     1295                    FillZeroCount    := ArrayFillerCount;
     1296                    ArrayFillerCount := 0;
     1297                  end;
     1298                  if FillZeroCount > 0 then
     1299                    Dec(FillZeroCount)
     1300                  else
     1301                    plongword(newArrayObj.ItemPtr[arrayIndex])^ := tempIdObject;
     1302                end;
     1303              end;
     1304            end;
     1305        except
     1306          on ex: Exception do
     1307            raise Exception.Create('Error while reading array of object. ' + ex.Message);
     1308        end;
     1309      end;
    7901310
    7911311    btMethodCall, btMethodResponse:
    792       raise Exception.Create('Method or not supported');
     1312      raise Exception.Create('Method or method response not supported');
    7931313
    7941314    btEndOfStream: EndOfStream := True;
    … …  
    8021322var
    8031323  byteLength, shift: byte;
    804   fullLength: longword;
     1324  fullLength: integer;
    8051325  utf8value:  string;
    8061326begin
    … …  
    8171337  if Stream.Read(utf8value[1], fullLength) <> fullLength then
    8181338    raise Exception.Create('String length error');
    819   Result := Utf8ToAnsi(utf8value);
     1339  Result := utf8value;
     1340end;
     1341
     1342function TDotNetDeserialization.LoadDotNetCharFromStream(Stream: TStream
     1343  ): string;
     1344var
     1345  tempByte: byte;
     1346  dataLen: Byte;
     1347  utf8value: string;
     1348begin
     1349  tempByte:= WinReadByte(Stream);
     1350
     1351  if tempByte and $80 = 0 then
     1352    dataLen := 1
     1353  else
     1354  if tempByte and $E0 = $C0 then
     1355    dataLen := 2
     1356  else
     1357  if tempByte and $F0 = $E0 then
     1358    dataLen := 3
     1359  else
     1360  if tempByte and $F8 = $F0 then
     1361    dataLen := 4
     1362  else
     1363    raise Exception.Create('Invalid UTF8 char');
     1364
     1365  setlength(utf8value, dataLen);
     1366  utf8value[1] := char(tempByte);
     1367  Stream.Read(utf8value[2], dataLen - 1);
     1368  Result := utf8value;
    8201369end;
    8211370
    … …  
    8311380    begin
    8321381      ClassName := LoadStringFromStream(Stream);
    833       Stream.Read(nbFields, 4);
     1382      nbFields := WinReadLongword(Stream);
    8341383      setlength(fieldNames, nbFields);
    8351384      setlength(fieldTypes, nbFields);
    … …  
    8371386        fieldNames[i] := LoadStringFromStream(Stream);
    8381387      for i := 0 to nbFields - 1 do
    839         Stream.Read(fieldTypes[i].category, 1);
     1388        fieldTypes[i].category := TTypeCategory(WinReadByte(Stream));
    8401389      for i := 0 to nbFields - 1 do
    841       begin
    842         fieldTypes[i].Name := '';
    843         fieldTypes[i].refAssembly := 0;
    844         fieldTypes[i].primitiveType := ptNone;
    845         case fieldTypes[i].category of
    846           ftPrimitiveType, ftArrayOfPrimitiveType:
    847           begin
    848             Stream.Read(fieldTypes[i].primitiveType, 1);
    849             fieldTypes[i].Name := PrimitiveTypeName(fieldTypes[i].primitiveType);
    850             if fieldTypes[i].category = ftArrayOfPrimitiveType then
    851               fieldTypes[i].Name += '[]';
    852           end;
    853           ftString: fieldTypes[i].Name      := 'String';
    854           ftObjectType: fieldTypes[i].Name  := 'Object';
    855           ftRuntimeType: fieldTypes[i].Name := LoadStringFromStream(Stream);
    856           ftGenericType:
    857           begin
    858             fieldTypes[i].Name := LoadStringFromStream(Stream);
    859             Stream.Read(fieldTypes[i].refAssembly, 4);
    860           end;
    861           ftArrayOfObject: fieldTypes[i].Name := 'Object[]';
    862           ftArrayOfString: fieldTypes[i].Name := 'String[]';
    863           else
    864             raise Exception.Create('Unknown field type tag (' + IntToStr(
    865               byte(fieldTypes[i].category)) + ')');
    866         end;
    867       end;
     1390        fieldTypes[i] := LoadFieldType(Stream,fieldTypes[i].category);
    8681391      if isRuntimeType then
    8691392        refAssembly := 0
    8701393      else
    871         Stream.Read(refAssembly, 4);
     1394        refAssembly := WinReadLongword(Stream);
    8721395    end;
    8731396  except
    … …  
    9061429
    9071430function TDotNetDeserialization.LoadValueFromStream(Stream: TStream;
    908   fieldType: TFieldType): string;
    909 var
    910   utf8value:    string;
    911   utf8len:      byte;
    912   tempByte:     byte;
    913   tempDouble:   double;
    914   tempSingle:   single;
    915   tempSByte:    shortint;
    916   tempUInt64:   QWord;
     1431  const fieldType: TFieldType): string;
     1432var
     1433  data : record
     1434    case byte of
     1435    1: (ptr: pointer);
     1436    2: (bytes: array[0..7] of byte);
     1437    end;
     1438  dataLen: longword;
    9171439  tempIdObject: longword;
    9181440begin
    9191441  try
    920     case fieldType.category of
    921       ftPrimitiveType: case fieldType.primitiveType of
    922           ptBoolean:
    923           begin
    924                  {$hints off}
    925             Stream.Read(tempByte, 1);
    926                  {$hints on}
    927             if tempByte = 0 then
    928               Result := 'False'
    929             else
    930             if tempByte = 1 then
    931               Result := 'True'
    932             else
    933               raise Exception.Create('Invalid boolean value (' +
    934                 IntToStr(tempByte) + ')');
    935           end;
    936           ptByte:
    937           begin
    938                  {$hints off}
    939             Stream.Read(tempByte, 1);
    940                  {$hints on}
    941             Result := IntToStr(tempByte);
    942           end;
    943           ptChar:
    944           begin
    945                  {$hints off}
    946             Stream.Read(tempByte, 1);
    947                  {$hints on}
    948             if tempByte and $80 = 0 then
    949               utf8len := 1
    950             else
    951             if tempByte and $E0 = $C0 then
    952               utf8len := 2
    953             else
    954             if tempByte and $F0 = $E0 then
    955               utf8len := 3
    956             else
    957             if tempByte and $F8 = $F0 then
    958               utf8len := 4
    959             else
    960               raise Exception.Create('Invalid UTF8 char');
    961             setlength(utf8value, utf8len);
    962             utf8value[1] := char(tempByte);
    963             Stream.Read(utf8value[2], utf8len - 1);
    964             Result := Utf8ToAnsi(utf8value);
    965           end;
    966           ptString, ptDecimal: Result := LoadStringFromStream(Stream);
    967           ptDouble:
    968           begin
    969               {$hints off}
    970             stream.Read(tempDouble, sizeof(tempDouble));
    971               {$hints on}
    972             Result := FloatToStr(tempDouble);
    973           end;
    974           ptInt16:
    975           begin
    976             Result := IntToStr(WinReadSmallInt(stream));
    977           end;
    978           ptInt32:
    979           begin
    980             Result := IntToStr(WinReadLongInt(stream));
    981           end;
    982           ptInt64:
    983           begin
    984             Result := IntToStr(WinReadInt64(stream));
    985           end;
    986           ptSByte:
    987           begin
    988               {$hints off}
    989             stream.Read(tempSByte, sizeof(tempSByte));
    990               {$hints on}
    991             Result := IntToStr(tempSByte);
    992           end;
    993           ptSingle:
    994           begin
    995               {$hints off}
    996             stream.Read(tempSingle, sizeof(tempSingle));
    997               {$hints on}
    998             Result := FloatToStr(tempSingle);
    999           end;
    1000           ptUInt16:
    1001           begin
    1002             Result := IntToStr(WinReadWord(stream));
    1003           end;
    1004           ptUInt32:
    1005           begin
    1006             Result := IntToStr(WinReadLongword(stream));
    1007           end;
    1008           ptUInt64:
    1009           begin
    1010             Result := IntToStr(WinReadQWord(stream));
    1011           end;
    1012           ptDateTime:
    1013           begin
    1014             tempUInt64 := WinReadQWord(stream);
    1015             Result     := DateTimeToStr(
    1016               (tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000);
    1017           end;
    1018           else
    1019             raise Exception.Create('Unknown primitive type (' + IntToStr(
    1020               byte(fieldType.primitiveType)) + ')');
     1442    if fieldType.Category = ftPrimitiveType then
     1443    begin
     1444      case fieldType.primitiveType of
     1445        ptChar: Result := LoadDotNetCharFromStream(Stream);
     1446        ptString, ptDecimal: Result := LoadStringFromStream(Stream);
     1447      else
     1448        begin
     1449          dataLen := GetFieldTypeSize(fieldType);
     1450          {$hints off}
     1451          stream.read(data,dataLen);
     1452          {$hints on}
     1453          result := DotNetValueToString(data,fieldType);
    10211454        end;
    1022       ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
    1023       ftArrayOfString, ftArrayOfPrimitiveType:
    1024       begin
    1025         tempIdObject := LoadNextFromStream(stream);
    1026         Result := '#' + IntToStr(tempIdObject);
    1027 
    1028       end;
    1029       else
    1030         raise Exception.Create('Unknown field type (' + IntToStr(
    1031           byte(fieldType.category)) + ')');
    1032     end;
     1455      end;
     1456    end else
     1457    if fieldType.Category in [ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject,
     1458        ftArrayOfString, ftArrayOfPrimitiveType] then
     1459    begin
     1460      tempIdObject := LoadNextFromStream(stream);
     1461      Result := '#' + IntToStr(tempIdObject);
     1462    end else
     1463      raise Exception.Create('Unknown field type (' + IntToStr(
     1464        byte(fieldType.category)) + ')');
    10331465  except
    10341466    on ex: Exception do
    … …  
    10371469end;
    10381470
    1039 function TDotNetDeserialization.GetTypeOfObject(idObject: longword): integer;
    1040 var
    1041   i: integer;
    1042 begin
    1043   for i := 0 to high(objects) do
    1044     if objects[i].idObject = idObject then
    1045     begin
    1046       Result := objects[i].numType;
    1047       exit;
    1048     end;
    1049   raise Exception.Create('Object not found (' + IntToStr(idObject) + ')');
     1471function TDotNetDeserialization.LoadFieldType(Stream: TStream; category: TTypeCategory
     1472  ): TFieldType;
     1473begin
     1474  result.category := category;
     1475  result.Name := '';
     1476  result.refAssembly := 0;
     1477  result.primitiveType := ptNone;
     1478  case category of
     1479    ftPrimitiveType, ftArrayOfPrimitiveType:
     1480    begin
     1481      result.primitiveType := TPrimitiveType(WinReadByte(stream));
     1482      result.Name := PrimitiveTypeName(result.primitiveType);
     1483      if result.category = ftArrayOfPrimitiveType then
     1484        result.Name += '[]';
     1485    end;
     1486    ftString: result.Name      := 'String';
     1487    ftObjectType: result.Name  := 'Object';
     1488    ftRuntimeType: result.Name := LoadStringFromStream(Stream);
     1489    ftGenericType:
     1490    begin
     1491      result.Name := LoadStringFromStream(Stream);
     1492      result.refAssembly := WinReadLongword(Stream);
     1493    end;
     1494    ftArrayOfObject: result.Name := 'Object[]';
     1495    ftArrayOfString: result.Name := 'String[]';
     1496    else
     1497      raise Exception.Create('Unknown field type tag (' + IntToStr(
     1498        byte(result.category)) + ')');
     1499  end;
    10501500end;
    10511501
Note: See TracChangeset for help on using the changeset viewer.