paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
master
lazarus-ccr/wst/trunk/base_binary_formatter.pas
inoussa 9a060b2d23 Fix Binary Format optional object read failing. 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4268 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2015-08-13 15:14:26 +00:00

2257 lines
63 KiB
ObjectPascal
Raw Permalink Blame History

{ This file is part of the Web Service Toolkit
Copyright (c) 2006 by Inoussa OUEDRAOGO
This file is provide under modified LGPL licence
( the files COPYING.modifiedLGPL and COPYING.LGPL).
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.
}
{$INCLUDE wst_global.inc}
unit base_binary_formatter;
interface
uses
Classes, SysUtils, Contnrs, TypInfo,
base_service_intf, binary_streamer, wst_types;
{$DEFINE wst_binary_header}
const
sBINARY_FORMAT_NAME = 'wst-binary';
sROOT = 'ROOT';
sSCOPE_INNER_NAME = 'INNER_VAL';
sFORMAT = 'format';
{$IFDEF wst_binary_header}
sHEADER = 'HEADER';
{$ENDIF}
type
EBinaryFormatterException = class(EServiceException)
end;
EBinaryException = class(EBaseRemoteException)
end;
TDataName = String;
TDataType = (
dtInt8U = 1, dtInt8S = 2,
dtInt16U = 3, dtInt16S = 4,
dtInt32U = 5, dtInt32S = 6,
dtInt64U = 7, dtInt64S = 8,
dtBool = 9,
dtAnsiChar = 10, dtWideChar = 11, dtEnum = 12,
dtSingle = 13, dtDouble = 14, dtExtended = 15, dtCurrency = 16,
dtAnsiString = 17, dtWideString = 18,
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString = 19,
{ $ENDIF WST_UNICODESTRING}
dtObject = 30, dtArray = 31
);
const
dtDefaultString =
{$IFDEF WST_UNICODESTRING}
{$IFDEF WST_DELPHI}
dtUnicodeString
{$ENDIF WST_DELPHI}
{$IFDEF FPC}
dtAnsiString
{$ENDIF FPC}
{$ELSE WST_UNICODESTRING}
dtAnsiString
{$ENDIF WST_UNICODESTRING}
;
type
PAnsiStringBuffer = ^TAnsiStringBuffer;
PWideStringBuffer = ^TWideStringBuffer;
{ $IFDEF WST_UNICODESTRING}
PUnicodeStringBuffer = ^TUnicodeStringBuffer;
{ $ENDIF WST_UNICODESTRING}
PObjectBuffer = ^TObjectBuffer;
PArrayBuffer = ^TArrayBuffer;
PDataBuffer = ^TDataBuffer;
TDataBuffer = Record
Name : TDataName;
Case DataType : TDataType of
dtInt8S : ( Int8S : TInt8S );
dtInt8U : ( Int8U : TInt8U );
dtInt16U : ( Int16U : TInt16U );
dtInt16S : ( Int16S : TInt16S );
dtInt32U : ( Int32U : TInt32U );
dtInt32S : ( Int32S : TInt32S );
dtInt64U : ( Int64U : TInt64U );
dtInt64S : ( Int64S : TInt64S );
dtBool : ( BoolData : TBoolData );
dtAnsiChar : ( AnsiCharData : TAnsiCharacter; );
dtWideChar : ( WideCharData : TWideCharacter; );
dtEnum : ( EnumData : TEnumData );
dtSingle : ( SingleData : TFloat_Single_4 );
dtDouble : ( DoubleData : TFloat_Double_8 );
dtExtended : ( ExtendedData : TFloat_Extended_10 );
dtCurrency : ( CurrencyData : TFloat_Currency_8 );
dtAnsiString : ( AnsiStrData : PAnsiStringBuffer );
dtWideString : ( WideStrData : PWideStringBuffer );
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString : ( UnicodeStrData : PUnicodeStringBuffer );
{ $ENDIF WST_UNICODESTRING}
dtObject : ( ObjectData : PObjectBuffer );
dtArray : ( ArrayData : PArrayBuffer );
End;
TAnsiStringBuffer = record
Data : TAnsiStringData;
end;
TWideStringBuffer = record
Data : TWideStringData;
end;
{ $IFDEF WST_UNICODESTRING}
TUnicodeStringBuffer = record
Data : TUnicodeStringData;
end;
{ $ENDIF WST_UNICODESTRING}
PObjectBufferItem = ^TObjectBufferItem;
TObjectBufferItem = Record
Data : PDataBuffer;
Next : PObjectBufferItem;
End;
TObjectBuffer = Record
NilObject : TBoolData;
Count : Integer;
Head : PObjectBufferItem;
Last : PObjectBufferItem;
Attributes : PObjectBuffer;
InnerData : PDataBuffer;
End;
PDataBufferList = ^TDataBufferList;
TDataBufferList = array[0..MAX_ARRAY_LENGTH] of PDataBuffer;
TArrayBuffer = Record
Count : Integer;
Items : PDataBufferList;
Attributes : PObjectBuffer;
End;
{ TStackItem }
TStackItem = class
private
FScopeObject: PDataBuffer;
FScopeType: TScopeType;
Public
constructor Create(const AScopeObject : PDataBuffer;AScopeType : TScopeType);
function GetItemCount():Integer;virtual;abstract;
function Find(var AName : TDataName):PDataBuffer;virtual;abstract;
function GetByIndex(const AIndex : Integer):PDataBuffer;virtual;abstract;
function CreateBuffer(
Const AName : String;
const ADataType : TDataType
):PDataBuffer;virtual;abstract;
function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;virtual;abstract;
function GetInnerBuffer():PDataBuffer;virtual;abstract;
procedure NilCurrentScope();virtual;abstract;
function IsCurrentScopeNil():Boolean;virtual;abstract;
property ScopeObject : PDataBuffer Read FScopeObject;
property ScopeType : TScopeType Read FScopeType;
function GetScopeItemNames(const AReturnList : TStrings) : Integer;virtual;abstract;
End;
{ TObjectStackItem }
TObjectStackItem = class(TStackItem)
Public
constructor Create(const AScopeObject : PDataBuffer);
function GetItemCount():Integer;override;
function Find(var AName : TDataName):PDataBuffer;override;
function GetByIndex(const AIndex : Integer):PDataBuffer;override;
function CreateBuffer(
Const AName : String;
const ADataType : TDataType
):PDataBuffer;override;
function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;override;
function GetInnerBuffer():PDataBuffer;override;
procedure NilCurrentScope();override;
function IsCurrentScopeNil():Boolean;override;
function GetScopeItemNames(const AReturnList : TStrings) : Integer;override;
End;
{ TArrayStackItem }
TArrayStackItem = class(TStackItem)
Private
FIndex : Integer;
Public
constructor Create(const AScopeObject : PDataBuffer);
function GetItemCount():Integer;override;
function Find(var AName : TDataName):PDataBuffer;override;
function GetByIndex(const AIndex : Integer):PDataBuffer;override;
function CreateBuffer(
Const AName : String;
const ADataType : TDataType
):PDataBuffer;override;
function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;override;
function GetInnerBuffer():PDataBuffer;overload;override;
procedure NilCurrentScope();override;
function IsCurrentScopeNil():Boolean;override;
function GetScopeItemNames(const AReturnList : TStrings) : Integer;override;
End;
{ TBaseBinaryFormatter }
TBaseBinaryFormatter = class(TSimpleFactoryItem,IFormatterBase)
private
FRootData : PDataBuffer;
FStack : TObjectStack;
FSerializationStyle : TSerializationStyle;
FPropMngr : IPropertyManager;
{$IFDEF wst_binary_header}
FHeaderEnterCount : Integer;
{$ENDIF}
protected
function GetCurrentScope: String;
function GetCurrentScopeObject():PDataBuffer;
procedure SetSerializationStyle(const ASerializationStyle : TSerializationStyle);
function GetSerializationStyle():TSerializationStyle;
protected
function HasScope():Boolean;
procedure CheckScope();
procedure ClearStack();{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PushStack(AScopeObject : PDataBuffer;Const AScopeType : TScopeType = stObject);{$IFDEF USE_INLINE}inline;{$ENDIF}
function StackTop():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF}
function PopStack():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetRootData() : PDataBuffer;{$IFDEF USE_INLINE}inline;{$ENDIF}
protected
procedure PutFloat(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : TFloat_Extended_10
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutInt(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : TInt64S
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutAnsiStr(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : AnsiString
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutWideStr(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : WideString
);{$IFDEF USE_INLINE}inline;{$ENDIF}
{ $IFDEF WST_UNICODESTRING}
procedure PutUnicodeStr(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : UnicodeString
);{$IFDEF USE_INLINE}inline;{$ENDIF}
{ $ENDIF WST_UNICODESTRING}
procedure PutEnum(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : TEnumData
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutBool(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : Boolean
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutAnsiChar(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : AnsiChar
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutWideChar(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : WideChar
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutInt64(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : Int64
);{$IFDEF USE_INLINE}inline;{$ENDIF}
{$IFDEF HAS_QWORD}
procedure PutUInt64(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : QWord
);{$IFDEF USE_INLINE}inline;{$ENDIF}
{$ENDIF HAS_QWORD}
procedure PutObj(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData : TObject
);{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure PutRecord(
const AName : string;
const ATypeInfo : PTypeInfo;
const AData : Pointer
);{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetDataBuffer(
var AName : string;
out AResultBuffer : PDataBuffer
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetEnum(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : TEnumData
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBool(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : Boolean
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetAnsiChar(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : AnsiChar
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWideChar(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : WideChar
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetFloat(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : TFloat_Extended_10
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetInt(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : TInt64S
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetInt64(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : Int64
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
{$IFDEF HAS_QWORD}
function GetUInt64(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : QWord
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
{$ENDIF}
function GetAnsiStr(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : AnsiString
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWideStr(
const ATypeInfo : PTypeInfo;
var AName : String;
var AData : WideString
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
{ $IFDEF WST_UNICODESTRING}
function GetUnicodeStr(
const ATypeInfo : PTypeInfo;
var AName : String;
var AData : UnicodeString
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
{ $ENDIF WST_UNICODESTRING}
function GetObj(
Const ATypeInfo : PTypeInfo;
Var AName : String;
Var AData : TObject
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetRecord(
const ATypeInfo : PTypeInfo;
var AName : String;
var AData : Pointer
) : Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
public
constructor Create();override;
destructor Destroy();override;
function GetFormatName() : string;
function GetPropertyManager():IPropertyManager;
procedure Clear();
procedure BeginObject(
Const AName : string;
Const ATypeInfo : PTypeInfo
);
procedure BeginArray(
const AName : string;
const ATypeInfo : PTypeInfo;
const AItemTypeInfo : PTypeInfo;
const ABounds : Array Of Integer;
const AStyle : TArrayStyle
);
procedure NilCurrentScope();
function IsCurrentScopeNil():Boolean;
procedure EndScope();
procedure AddScopeAttribute(Const AName,AValue : string);
function BeginObjectRead(
var AScopeName : string;
const ATypeInfo : PTypeInfo
) : Integer;
function BeginArrayRead(
var AScopeName : string;
const ATypeInfo : PTypeInfo;
const AStyle : TArrayStyle;
const AItemName : string
):Integer;
function GetScopeItemNames(const AReturnList : TStrings) : Integer;
procedure EndScopeRead();
procedure BeginHeader();
procedure EndHeader();
property CurrentScope : String Read GetCurrentScope;
procedure Put(
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData
);overload;
procedure Put(
const ANameSpace : string;
Const AName : String;
Const ATypeInfo : PTypeInfo;
Const AData
);overload;
procedure PutScopeInnerValue(
const ATypeInfo : PTypeInfo;
const AData
);
function Get(
const ATypeInfo : PTypeInfo;
var AName : string;
var AData
) : Boolean;overload;
function Get(
const ATypeInfo : PTypeInfo;
const ANameSpace : string;
var AName : string;
var AData
) : Boolean; overload;
procedure GetScopeInnerValue(
const ATypeInfo : PTypeInfo;
var AData
);
function ReadBuffer(const AName : string; out AResBuffer : string) : Boolean;
procedure WriteBuffer(const AValue : string);
procedure SaveToStream(AStream : TStream);
procedure LoadFromStream(AStream : TStream);
procedure Error(Const AMsg:string);overload;
procedure Error(Const AMsg:string; Const AArgs : array of const);overload;
End;
TDBGPinterProc = procedure(const AMsg:string);
procedure ClearObj(const AOwner: PDataBuffer);
procedure FreeObjectBuffer(var ABuffer : PDataBuffer); overload;
function LoadObjectFromStream(const AStoreRdr : IDataStoreReader):PDataBuffer;
procedure SaveObjectToStream(const ARoot: PDataBuffer; const ADest : IDataStore);
function CreateArrayBuffer(
const ALength : Integer;
const AName : TDataName;
const AOwner : PDataBuffer = nil
):PDataBuffer;
function CreateObjBuffer(
const ADataType : TDataType;
const AName : TDataName;
const AOwner : PDataBuffer = nil
):PDataBuffer;
procedure PrintObj(const ARoot: PDataBuffer; const ALevel : Integer; const APrinterProc : TDBGPinterProc);
implementation
uses
imp_utils, wst_consts;
{$INCLUDE wst_rtl_imp.inc}
procedure PrintObj(const ARoot: PDataBuffer; const ALevel : Integer; const APrinterProc : TDBGPinterProc);
Var
p : PObjectBufferItem;
s : string;
i ,j: Integer;
Begin
If Not Assigned(ARoot) Then
Exit;
s := StringOfChar(' ',ALevel);
Case ARoot^.DataType Of
dtInt8S : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int8S) );
dtInt8U : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int8U) );
dtInt32U : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int32U) );
dtInt32S : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int32S) );
dtInt64U : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int64U) );
dtInt64S : APrinterProc( s + ARoot^.Name + ' = ' + IntToStr(ARoot^.Int64S) );
dtSingle : APrinterProc( s + ARoot^.Name + ' = ' + FloatToStr(ARoot^.SingleData) );
dtDouble : APrinterProc( s + ARoot^.Name + ' = ' + FloatToStr(ARoot^.DoubleData) );
dtExtended : APrinterProc( s + ARoot^.Name + ' = ' + FloatToStr(ARoot^.ExtendedData) );
dtCurrency : APrinterProc( s + ARoot^.Name + ' = ' + FloatToStr(ARoot^.CurrencyData) );
dtAnsiString : APrinterProc( s + ARoot^.Name + ' = ' + ARoot^.AnsiStrData^.Data );
dtWideString : APrinterProc( s + ARoot^.Name + ' = ' + ARoot^.WideStrData^.Data );
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString : APrinterProc( s + ARoot^.Name + ' = ' + ARoot^.UnicodeStrData^.Data );
{ $ENDIF WST_UNICODESTRING}
dtObject :
Begin
APrinterProc( s + ARoot^.Name + ' = ');
If Not Assigned(ARoot^.ObjectData) Then Begin
APrinterProc(s + ' <Vide>');
End Else Begin
APrinterProc('( ' + IntToStr(ARoot^.ObjectData^.Count) + ' Objects )');
p := ARoot^.ObjectData^.Head;
i := ALevel + 1;
While Assigned(p) Do Begin
PrintObj(p^.Data,i,APrinterProc);
p := p^.Next;
End;
End;
End;
dtArray :
Begin
APrinterProc( s + ARoot^.Name + ' = ');
If Not Assigned(ARoot^.ArrayData) Then Begin
APrinterProc(s + ' <Vide>');
End Else Begin
j := ARoot^.ArrayData^.Count;
APrinterProc('( Objects[ '+ IntToStr(j)+ '] )');
i := ALevel + 1;
For j := 0 To Pred(j) Do Begin
PrintObj(ARoot^.ArrayData^.Items^[j],i,APrinterProc);
End;
End;
End;
End;
End;
function FindObj(const AOwner: PDataBuffer; const AName : TDataName) : PDataBuffer;
Var
p : PObjectBufferItem;
Begin
Assert(AOwner^.DataType >= dtObject);
Result := Nil;
p:= AOwner^.ObjectData^.Head;
While Assigned(p) Do Begin
If AnsiSameText(AName,p^.Data^.Name) Then Begin
Result := p^.Data;
Exit;
End;
p := p^.Next;
End;
End;
procedure AddObj(
const AOwner, AChildData: PDataBuffer;
const AIndex : Integer = -1
);
Var
p : PObjectBufferItem;
Begin
If ( AOwner^.DataType = dtObject ) Then Begin
p := wst_GetMem(SizeOf(TObjectBufferItem));
p^.Data := AChildData;
p^.Next := Nil;
If Assigned(AOwner^.ObjectData^.Head) Then Begin
AOwner^.ObjectData^.Last^.Next := p;
End Else Begin
AOwner^.ObjectData^.Head := p;
End;
AOwner^.ObjectData^.Last := p;
Inc(AOwner^.ObjectData^.Count);
End Else If ( AOwner^.DataType = dtArray ) Then Begin
If ( AIndex >= 0 ) And ( AIndex < AOwner^.ArrayData^.Count ) Then
AOwner^.ArrayData^.Items^[AIndex] := AChildData
Else
Raise EBinaryFormatterException.CreateFmt(SERR_IndexOutOfBound,[AIndex])
End Else Begin
Raise EBinaryFormatterException.CreateFmt(SERR_InvalidDataTypeInContext,[IntToStr(Ord(AOwner^.DataType))])
End;
End;
function CreateObjBuffer(
const ADataType : TDataType;
const AName : TDataName;
const AOwner : PDataBuffer = nil
):PDataBuffer;
var
resLen, i : Integer;
begin
resLen := SizeOf(TDataBuffer);
Result := wst_GetMem(resLen);
Try
FillChar(Result^,resLen,#0);
Result^.Name := AName;
Result^.DataType := ADataType;
Case Result^.DataType Of
dtAnsiString :
Begin
i := SizeOf(TAnsiStringBuffer);
Result^.AnsiStrData := wst_GetMem(i);
FillChar(Result^.AnsiStrData^,i,#0);
Result^.AnsiStrData^.Data := '';
End;
dtWideString :
begin
i := SizeOf(TWideStringBuffer);
Result^.WideStrData := wst_GetMem(i);
FillChar(Result^.WideStrData^,i,#0);
Result^.WideStrData^.Data := '';
end;
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString :
begin
i := SizeOf(TUnicodeStringBuffer);
Result^.UnicodeStrData := wst_GetMem(i);
FillChar(Result^.UnicodeStrData^,i,#0);
Result^.UnicodeStrData^.Data := '';
end;
{ $ENDIF WST_UNICODESTRING}
dtObject :
Begin
Result^.ObjectData := wst_GetMem(SizeOf(TObjectBuffer));
FillChar(Result^.ObjectData^,SizeOf(TObjectBuffer),#0);
End;
End;
If Assigned(AOwner) Then
AddObj(AOwner,Result);
Except
Freemem(Result,resLen);
Raise;
End;
end;
function CreateArrayBuffer(
const ALength : Integer;
const AName : TDataName;
const AOwner : PDataBuffer = nil
):PDataBuffer;
Var
i, resLen : Integer;
begin
Assert(ALength>=0);
resLen := SizeOf(TDataBuffer);
Result := wst_GetMem(resLen);
Try
FillChar(Result^,resLen,#0);
Result^.Name := AName;
Result^.DataType := dtArray;
Result^.ArrayData := wst_GetMem(SizeOf(TArrayBuffer));
FillChar(Result^.ArrayData^,SizeOf(TArrayBuffer),#0);
Result^.ArrayData^.Count := ALength;
If ( ALength > 0 ) Then Begin
i := ALength*SizeOf(PDataBuffer);
Result^.ArrayData^.Items := wst_GetMem(i);
FillChar(Result^.ArrayData^.Items^[0],i,#0);
End Else Begin
Result^.ArrayData^.Items := Nil;
End;
If Assigned(AOwner) Then
AddObj(AOwner,Result);
Except
Freemem(Result,resLen);
Raise;
End;
end;
procedure SaveObjectToStream(const ARoot: PDataBuffer; const ADest : IDataStore);
Var
p : PObjectBufferItem;
i : TInt32S;
Begin
If Not Assigned(ARoot) Then
Exit;
i := Ord(ARoot^.DataType);
ADest.WriteInt32S(i);
ADest.WriteAnsiStr(ARoot^.Name);
Case ARoot^.DataType Of
dtInt8S : ADest.WriteInt8S(ARoot^.Int8S);
dtInt8U : ADest.WriteInt8U(ARoot^.Int8U);
dtInt16U : ADest.WriteInt16U(ARoot^.Int16U);
dtInt16S : ADest.WriteInt16S(ARoot^.Int16S);
dtInt32U : ADest.WriteInt32U(ARoot^.Int32U);
dtInt32S : ADest.WriteInt32S(ARoot^.Int32S);
dtInt64U : ADest.WriteInt64U(ARoot^.Int64U);
dtInt64S : ADest.WriteInt64S(ARoot^.Int64S);
dtSingle : ADest.WriteSingle(ARoot^.SingleData);
dtDouble : ADest.WriteDouble(ARoot^.DoubleData);
dtExtended : ADest.WriteExtended(ARoot^.ExtendedData);
dtCurrency : ADest.WriteCurrency(ARoot^.CurrencyData);
dtAnsiString : ADest.WriteAnsiStr(ARoot^.AnsiStrData^.Data);
dtWideString : ADest.WriteWideStr(ARoot^.WideStrData^.Data);
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString : ADest.WriteUnicodeStr(ARoot^.UnicodeStrData^.Data);
{ $ENDIF WST_UNICODESTRING}
dtBool : ADest.WriteBool(ARoot^.BoolData);
dtAnsiChar : ADest.WriteAnsiChar(ARoot^.AnsiCharData);
dtWideChar : ADest.WriteWideChar(ARoot^.WideCharData);
dtEnum : ADest.WriteEnum(ARoot^.EnumData);
dtObject :
Begin
ADest.WriteBool(ARoot^.ObjectData^.NilObject) ;
if not ARoot^.ObjectData^.NilObject then begin
i := ARoot^.ObjectData^.Count;
ADest.WriteInt32S(i);
If ( i > 0 ) Then Begin
p := ARoot^.ObjectData^.Head;
For i := 1 To i Do Begin
SaveObjectToStream(p^.Data,ADest);
p := p^.Next;
End;
End;
ADest.WriteBool(Assigned(ARoot^.ObjectData^.InnerData));
if Assigned(ARoot^.ObjectData^.InnerData) then
SaveObjectToStream(ARoot^.ObjectData^.InnerData,ADest);
end;
End;
dtArray :
Begin
i := ARoot^.ArrayData^.Count;
ADest.WriteInt32S(i);
If ( i > 0 ) Then Begin
For i := 0 To Pred(i) Do Begin
SaveObjectToStream(ARoot^.ArrayData^.Items^[i],ADest);
End;
End;
End;
End;
End;
function LoadObjectFromStream(const AStoreRdr : IDataStoreReader):PDataBuffer;
Var
i : TInt32S;
s : string;
Begin
Result := Nil;
If AStoreRdr.IsAtEof() Then
Exit;
i := AStoreRdr.ReadInt32S();
s := AStoreRdr.ReadAnsiStr();
If ( TDataType(i) < dtArray ) Then
Result := CreateObjBuffer(TDataType(i),s);
Case TDataType(i) Of
dtInt8S : Result^.Int8S := AStoreRdr.ReadInt8S();
dtInt8U : Result^.Int8U := AStoreRdr.ReadInt8U();
dtInt16U : Result^.Int16U := AStoreRdr.ReadInt16U();
dtInt16S : Result^.Int16S := AStoreRdr.ReadInt16S();
dtInt32U : Result^.Int32U := AStoreRdr.ReadInt32U();
dtInt32S : Result^.Int32S := AStoreRdr.ReadInt32S();
dtInt64U : Result^.Int64U := AStoreRdr.ReadInt64U();
dtInt64S : Result^.Int64S := AStoreRdr.ReadInt64S();
dtSingle : Result^.SingleData := AStoreRdr.ReadSingle();
dtDouble : Result^.DoubleData := AStoreRdr.ReadDouble();
dtExtended : Result^.ExtendedData := AStoreRdr.ReadExtended();
dtCurrency : Result^.CurrencyData := AStoreRdr.ReadCurrency();
dtAnsiString : Result^.AnsiStrData^.Data := AStoreRdr.ReadAnsiStr();
dtWideString : Result^.WideStrData^.Data := AStoreRdr.ReadWideStr();
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString : Result^.UnicodeStrData^.Data := AStoreRdr.ReadUnicodeStr();
{ $ENDIF WST_UNICODESTRING}
dtBool : Result^.BoolData := AStoreRdr.ReadBool();
dtAnsiChar : Result^.AnsiCharData := AStoreRdr.ReadAnsiChar();
dtWideChar : Result^.WideCharData := AStoreRdr.ReadWideChar();
dtEnum : Result^.EnumData := AStoreRdr.ReadEnum();
dtObject :
Begin
Result^.ObjectData^.NilObject := AStoreRdr.ReadBool();
if not Result^.ObjectData^.NilObject then begin
i := AStoreRdr.ReadInt32S();
For i := 1 To i Do Begin
AddObj(Result,LoadObjectFromStream(AStoreRdr));
End;
if AStoreRdr.ReadBool() then
Result^.ObjectData^.InnerData := LoadObjectFromStream(AStoreRdr);
end;
end;
dtArray :
Begin
i := AStoreRdr.ReadInt32S();
Result := CreateArrayBuffer(i,s);
For i := 0 To Pred(i) Do Begin
AddObj(Result,LoadObjectFromStream(AStoreRdr),i);
End;
End;
End;
End;
procedure FreeObjectBuffer(var ABuffer : PObjectBuffer);overload;
var
p,q : PObjectBufferItem;
begin
if Assigned(ABuffer) then begin
if Assigned(ABuffer^.Attributes) then
FreeObjectBuffer(ABuffer^.Attributes);
p := ABuffer^.Head;
while Assigned(p) do begin
q := p;
p := p^.Next;
ClearObj(q^.Data);
Freemem(q^.Data);
q^.Data := Nil;
Freemem(q);
end;
if Assigned(ABuffer^.InnerData) then begin
ClearObj(ABuffer^.InnerData);
Freemem(ABuffer^.InnerData);
ABuffer^.InnerData := nil;
end;
//ABuffer^.Head := nil;
//ABuffer^.Last := nil;
Freemem(ABuffer);
ABuffer := nil;
end;
end;
procedure FreeObjectBuffer(var ABuffer : PDataBuffer);
var
tmpBuffer : PDataBuffer;
begin
if ( ABuffer <> nil ) then begin
tmpBuffer := ABuffer;
ABuffer := nil;
ClearObj(tmpBuffer);
FreeMem(tmpBuffer)
end;
end;
procedure ClearObj(const AOwner: PDataBuffer);
Var
i , j: Integer;
eltLen : Integer;
Begin
AOwner^.Name := '';
Case AOwner^.DataType Of
dtAnsiString :
Begin
AOwner^.AnsiStrData^.Data := '';
Freemem(AOwner^.AnsiStrData);
AOwner^.AnsiStrData := Nil;
End;
dtWideString :
begin
AOwner^.WideStrData^.Data := '';
Freemem(AOwner^.WideStrData);
AOwner^.WideStrData := Nil;
end;
{ $IFDEF WST_UNICODESTRING}
dtUnicodeString :
begin
AOwner^.UnicodeStrData^.Data := '';
Freemem(AOwner^.UnicodeStrData);
AOwner^.UnicodeStrData := Nil;
end;
{ $ENDIF WST_UNICODESTRING}
dtObject :
Begin
FreeObjectBuffer(AOwner^.ObjectData);
End;
dtArray :
Begin
eltLen := SizeOf(TDataBuffer);
For j := 0 to Pred(AOwner^.ArrayData^.Count) Do Begin
ClearObj(AOwner^.ArrayData^.Items^[j]);
Freemem(AOwner^.ArrayData^.Items^[j],eltLen);
AOwner^.ArrayData^.Items^[j] := Nil;
End;
i := AOwner^.ArrayData^.Count * SizeOf(PDataBuffer);
Freemem(AOwner^.ArrayData^.Items,i);
AOwner^.ArrayData^.Items := Nil;
FreeObjectBuffer(AOwner^.ArrayData^.Attributes);
i := SizeOf(TArrayBuffer);
Freemem(AOwner^.ArrayData,i);
AOwner^.ArrayData := Nil;
End;
End;
End;
{ TStackItem }
constructor TStackItem.Create(const AScopeObject: PDataBuffer; AScopeType: TScopeType);
begin
Assert(Assigned(AScopeObject));
FScopeObject := AScopeObject;
FScopeType := AScopeType;
end;
{ TObjectStackItem }
constructor TObjectStackItem.Create(const AScopeObject: PDataBuffer);
begin
Inherited Create(AScopeObject,stObject);
end;
function TObjectStackItem.GetItemCount(): Integer;
begin
Result := ScopeObject^.ObjectData^.Count;
end;
function TObjectStackItem.Find(var AName: TDataName): PDataBuffer;
begin
Result := FindObj(ScopeObject,AName);
end;
function TObjectStackItem.GetByIndex(const AIndex: Integer): PDataBuffer;
Var
p : PObjectBufferItem;
i : Integer;
begin
If ( AIndex >=0 ) And ( AIndex < ScopeObject^.ObjectData^.Count) Then Begin
p := ScopeObject^.ObjectData^.Head;
For i := 1 To AIndex Do
p := p^.Next;
Result := p^.Data;
End Else
Raise EBinaryFormatterException.CreateFmt(SERR_IndexOutOfBound,[AIndex]);
end;
function TObjectStackItem.CreateBuffer(
Const AName : String;
const ADataType : TDataType
):PDataBuffer;
begin
Result := CreateObjBuffer(ADataType,AName,ScopeObject);
end;
function TObjectStackItem.CreateInnerBuffer(const ADataType: TDataType): PDataBuffer;
begin
Result := CreateObjBuffer(ADataType,sSCOPE_INNER_NAME,nil);
ScopeObject^.ObjectData^.InnerData := Result;
end;
function TObjectStackItem.GetInnerBuffer(): PDataBuffer;
begin
Result := ScopeObject^.ObjectData^.InnerData;
end;
procedure TObjectStackItem.NilCurrentScope();
begin
Assert(ScopeObject^.ObjectData^.Count = 0);
ScopeObject^.ObjectData^.NilObject := True;
end;
function TObjectStackItem.IsCurrentScopeNil(): Boolean;
begin
Result := ScopeObject^.ObjectData^.NilObject;
end;
//----------------------------------------------------------------
function TObjectStackItem.GetScopeItemNames(const AReturnList: TStrings): Integer;
var
locBuffer : PObjectBufferItem;
begin
AReturnList.Clear();
if Assigned(ScopeObject) and ( ScopeObject^.ObjectData^.Count > 0 ) then begin
locBuffer := ScopeObject^.ObjectData^.Head;
while Assigned(locBuffer) do begin
AReturnList.Add(locBuffer^.Data^.Name);
locBuffer := locBuffer^.Next;
end;
end;
Result := AReturnList.Count;
end;
{ TBaseBinaryFormatter }
procedure TBaseBinaryFormatter.ClearStack();
Var
i, c : Integer;
begin
c := FStack.Count;
For I := 1 To c Do
FStack.Pop().Free();
end;
procedure TBaseBinaryFormatter.PushStack(AScopeObject: PDataBuffer;const AScopeType: TScopeType);
begin
If ( AScopeType = stObject ) Then
FStack.Push(TObjectStackItem.Create(AScopeObject))
Else If ( AScopeType = stArray ) Then
FStack.Push(TArrayStackItem.Create(AScopeObject))
Else
Assert(False);
end;
function TBaseBinaryFormatter.StackTop(): TStackItem;
begin
Result := FStack.Peek() as TStackItem;
end;
function TBaseBinaryFormatter.PopStack(): TStackItem;
begin
Result := FStack.Pop() as TStackItem;
end;
function TBaseBinaryFormatter.GetRootData(): PDataBuffer;
begin
Result := FRootData;
end;
procedure TBaseBinaryFormatter.PutFloat(
const AName : String;
const ATypeInfo : PTypeInfo;
const AData : TFloat_Extended_10
);
begin
Case GetTypeData(ATypeInfo)^.FloatType Of
ftSingle : StackTop().CreateBuffer(AName,dtSingle)^.SingleData := AData;
ftDouble : StackTop().CreateBuffer(AName,dtDouble)^.DoubleData := AData;
ftExtended : StackTop().CreateBuffer(AName,dtExtended)^.ExtendedData := AData;
ftCurr : StackTop().CreateBuffer(AName,dtCurrency)^.CurrencyData := AData;
Else
StackTop().CreateBuffer(AName,dtExtended)^.ExtendedData := AData;
End;
end;
function TBaseBinaryFormatter.GetCurrentScopeObject(): PDataBuffer;
begin
Result := StackTop().ScopeObject;
end;
procedure TBaseBinaryFormatter.SetSerializationStyle(
const ASerializationStyle: TSerializationStyle
);
begin
FSerializationStyle := ASerializationStyle;
end;
function TBaseBinaryFormatter.GetSerializationStyle(): TSerializationStyle;
begin
Result := FSerializationStyle;
end;
function TBaseBinaryFormatter.HasScope(): Boolean;
begin
Result := ( FStack.Peek <> nil );
end;
procedure TBaseBinaryFormatter.CheckScope();
begin
If Not HasScope() Then
Error(SERR_NoScope);
end;
function TBaseBinaryFormatter.GetCurrentScope: String;
begin
Result := GetCurrentScopeObject()^.Name;
end;
procedure TBaseBinaryFormatter.PutInt(
const AName : String;
const ATypeInfo : PTypeInfo;
const AData : TInt64S
);
begin
Case GetTypeData(ATypeInfo)^.OrdType Of
otSByte : StackTop().CreateBuffer(AName,dtInt8S)^.Int8S := AData;
otUByte : StackTop().CreateBuffer(AName,dtInt8U)^.Int8U := AData;
otSWord : StackTop().CreateBuffer(AName,dtInt16S)^.Int16S := AData;
otUWord : StackTop().CreateBuffer(AName,dtInt16U)^.Int16U := AData;
otULong : StackTop().CreateBuffer(AName,dtInt32U)^.Int32U := AData;
otSLong : StackTop().CreateBuffer(AName,dtInt32S)^.Int32S := AData;
End;
end;
procedure TBaseBinaryFormatter.PutAnsiStr(
const AName : String;
const ATypeInfo : PTypeInfo;
const AData : AnsiString
);
begin
StackTop().CreateBuffer(AName,dtAnsiString)^.AnsiStrData^.Data := AData;
end;
procedure TBaseBinaryFormatter.PutWideStr(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: WideString
);
begin
StackTop().CreateBuffer(AName,dtWideString)^.WideStrData^.Data := AData;
end;
{ $IFDEF WST_UNICODESTRING}
procedure TBaseBinaryFormatter.PutUnicodeStr(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: UnicodeString
);
begin
StackTop().CreateBuffer(AName,dtUnicodeString)^.UnicodeStrData^.Data := AData;
end;
{ $ENDIF WST_UNICODESTRING}
procedure TBaseBinaryFormatter.PutEnum(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: TEnumData
);
begin
StackTop().CreateBuffer(AName,dtEnum)^.EnumData := AData;
end;
procedure TBaseBinaryFormatter.PutBool(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: Boolean
);
begin
StackTop().CreateBuffer(AName,dtBool)^.BoolData := AData;
end;
procedure TBaseBinaryFormatter.PutAnsiChar(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: AnsiChar
);
begin
StackTop().CreateBuffer(AName,dtAnsiChar)^.AnsiCharData := AData;
end;
procedure TBaseBinaryFormatter.PutWideChar(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: WideChar
);
begin
StackTop().CreateBuffer(AName,dtWideChar)^.WideCharData := AData;
end;
procedure TBaseBinaryFormatter.PutInt64(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: Int64
);
begin
StackTop().CreateBuffer(AName,dtInt64S)^.Int64S := AData;
end;
{$IFDEF HAS_QWORD}
procedure TBaseBinaryFormatter.PutUInt64(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: QWord
);
begin
StackTop().CreateBuffer(AName,dtInt64U)^.Int64U := AData;
end;
{$ENDIF HAS_QWORD}
procedure TBaseBinaryFormatter.PutObj(
const AName: String;
const ATypeInfo: PTypeInfo;
const AData: TObject
);
begin
TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Save(AData As TBaseRemotable, Self,AName,ATypeInfo);
end;
procedure TBaseBinaryFormatter.PutRecord(
const AName : string;
const ATypeInfo : PTypeInfo;
const AData : Pointer
);
begin
TRemotableRecordEncoder.Save(AData,Self,AName,ATypeInfo);
end;
function TBaseBinaryFormatter.GetDataBuffer(
var AName: string;
out AResultBuffer : PDataBuffer
) : Boolean;
begin
AResultBuffer := StackTop().Find(AName);
Result := ( AResultBuffer <> nil );
end;
function TBaseBinaryFormatter.GetEnum(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: TEnumData
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.EnumData;
end;
function TBaseBinaryFormatter.GetBool(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: Boolean
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.BoolData;
end;
function TBaseBinaryFormatter.GetAnsiChar(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: AnsiChar
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.AnsiCharData;
end;
function TBaseBinaryFormatter.GetWideChar(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: WideChar
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.WideCharData;
end;
function TBaseBinaryFormatter.GetFloat(
const ATypeInfo : PTypeInfo;
var AName : String;
var AData : TFloat_Extended_10
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then begin
case GetTypeData(ATypeInfo)^.FloatType Of
ftSingle : AData := locBuffer^.SingleData;
ftDouble : AData := locBuffer^.DoubleData;
ftExtended : AData := locBuffer^.ExtendedData;
ftCurr : AData := locBuffer^.CurrencyData;
else
AData := locBuffer^.ExtendedData;
end;
end;
end;
function TBaseBinaryFormatter.GetInt(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: TInt64S
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then begin
case GetTypeData(ATypeInfo)^.OrdType of
otSByte : AData := locBuffer^.Int8S;
otUByte : AData := locBuffer^.Int8U;
otSWord : AData := locBuffer^.Int16S;
otUWord : AData := locBuffer^.Int16U;
otSLong : AData := locBuffer^.Int32S;
otULong : AData := locBuffer^.Int32U;
Else
Assert(False);
end;
end;
end;
function TBaseBinaryFormatter.GetInt64(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: Int64
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.Int64S;
end;
{$IFDEF HAS_QWORD}
function TBaseBinaryFormatter.GetUInt64(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: QWord
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then
AData := locBuffer^.Int64U;
end;
{$ENDIF HAS_QWORD}
function TBaseBinaryFormatter.GetAnsiStr(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: AnsiString
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then begin
case locBuffer^.DataType of
dtUnicodeString : AData := locBuffer^.UnicodeStrData^.Data;
dtWideString : AData := locBuffer^.WideStrData^.Data;
else
AData := locBuffer^.AnsiStrData^.Data;
end;
end;
end;
function TBaseBinaryFormatter.GetWideStr(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: WideString
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then begin
case locBuffer^.DataType of
dtAnsiString : AData := locBuffer^.AnsiStrData^.Data;
dtUnicodeString : AData := locBuffer^.UnicodeStrData^.Data;
else
AData := locBuffer^.WideStrData^.Data;
end;
end;
end;
{ $IFDEF WST_UNICODESTRING}
function TBaseBinaryFormatter.GetUnicodeStr(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: UnicodeString
) : Boolean;
var
locBuffer : PDataBuffer;
begin
Result := GetDataBuffer(AName,locBuffer);
if Result then begin
case locBuffer^.DataType of
dtAnsiString : AData := locBuffer^.AnsiStrData^.Data;
dtWideString : AData := locBuffer^.WideStrData^.Data;
else
AData := locBuffer^.UnicodeStrData^.Data;
end;
end;
end;
{ $ENDIF WST_UNICODESTRING}
function TBaseBinaryFormatter.GetObj(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData: TObject
) : Boolean;
begin
{ TODO -cEXCEPTION_SAFE : Load() should be a function ! }
TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Load(AData, Self,AName,ATypeInfo);
Result := True;
end;
function TBaseBinaryFormatter.GetRecord(
const ATypeInfo : PTypeInfo;
var AName : String;
var AData : Pointer
) : Boolean;
begin
{ TODO -cEXCEPTION_SAFE : Load() should be a function ! }
TRemotableRecordEncoder.Load(AData, Self,AName,ATypeInfo);
Result := True;
end;
procedure TBaseBinaryFormatter.Clear();
begin
ClearStack();
ClearObj(FRootData);
Freemem(FRootData);
FRootData := CreateObjBuffer(dtObject,sROOT);
PushStack(FRootData,stObject);
end;
procedure TBaseBinaryFormatter.BeginArray(
const AName : string;
const ATypeInfo : PTypeInfo;
const AItemTypeInfo : PTypeInfo;
const ABounds : Array Of Integer;
const AStyle : TArrayStyle
);
var
i, j, k : Integer;
begin
If ( Length(ABounds) < 2 ) Then
Raise EBinaryFormatterException.Create(SERR_InvalidArrayBounds);
i := ABounds[0];
j := ABounds[1];
k := ( j - i + 1 );
If ( k < 0 ) Then
Raise EBinaryFormatterException.Create(SERR_InvalidArrayBounds);
PushStack(CreateArrayBuffer(k,AName,StackTop().ScopeObject),stArray);
end;
procedure TBaseBinaryFormatter.NilCurrentScope();
begin
CheckScope();
StackTop().NilCurrentScope();
end;
function TBaseBinaryFormatter.IsCurrentScopeNil(): Boolean;
begin
Result := StackTop().IsCurrentScopeNil();
end;
procedure TBaseBinaryFormatter.BeginObject(
const AName: string;
const ATypeInfo: PTypeInfo
);
begin
PushStack(StackTop().CreateBuffer(AName,dtObject));
end;
procedure TBaseBinaryFormatter.EndScope();
begin
FStack.Pop().Free();
end;
procedure TBaseBinaryFormatter.AddScopeAttribute(const AName, AValue: string);
begin
end;
function TBaseBinaryFormatter.BeginObjectRead(
var AScopeName : string;
const ATypeInfo : PTypeInfo
): Integer;
var
locNode : PDataBuffer;
stk : TStackItem;
begin
stk := StackTop();
locNode := stk.Find(AScopeName);
if (locNode <> nil) then begin
PushStack(locNode,stObject);
Result := StackTop().GetItemCount();
end else begin
Result := -1;
end;
end;
function TBaseBinaryFormatter.BeginArrayRead(
var AScopeName : string;
const ATypeInfo : PTypeInfo;
const AStyle : TArrayStyle;
const AItemName : string
): Integer;
var
locNode : PDataBuffer;
stk : TStackItem;
begin
stk := StackTop();
locNode := stk.Find(AScopeName);
if ( locNode <> nil ) then begin
PushStack(locNode,stArray);
Result := StackTop().GetItemCount();
end else begin
Result := -1;
end;
end;
function TBaseBinaryFormatter.GetScopeItemNames(const AReturnList : TStrings) : Integer;
begin
CheckScope();
Result := StackTop.GetScopeItemNames(AReturnList);
end;
procedure TBaseBinaryFormatter.EndScopeRead();
begin
PopStack().Free();
end;
procedure TBaseBinaryFormatter.BeginHeader();
begin
{$IFDEF wst_binary_header}
if ( FHeaderEnterCount <= 0 ) then begin
Inc(FHeaderEnterCount);
BeginObject(sHEADER,nil);
end;
{$ENDIF}
end;
procedure TBaseBinaryFormatter.EndHeader();
begin
{$IFDEF wst_binary_header}
if ( FHeaderEnterCount > 0 ) then begin
Dec(FHeaderEnterCount);
EndScope();
end;
{$ENDIF}
end;
procedure TBaseBinaryFormatter.Put(const AName: String; const ATypeInfo: PTypeInfo;const AData);
Var
int64Data : Int64;
{$IFDEF HAS_QWORD}
uint64Data : QWOrd;
{$ENDIF HAS_QWORD}
ansiStrData : AnsiString;
objData : TObject;
boolData : Boolean;
enumData : TEnumData;
floatDt : TFloat_Extended_10;
wideStrData : WideString;
{$IFDEF WST_UNICODESTRING}
unicodeStrData : UnicodeString;
{$ENDIF WST_UNICODESTRING}
ansiCharData : AnsiChar;
wideCharData : WideChar;
begin
Case ATypeInfo^.Kind Of
tkChar :
begin
ansiCharData := AnsiChar(AData);
PutAnsiChar(AName,ATypeInfo,ansiCharData);
end;
tkWChar :
begin
wideCharData := WideChar(AData);
PutWideChar(AName,ATypeInfo,wideCharData);
end;
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
Begin
ansiStrData := AnsiString(AData);
PutAnsiStr(AName,ATypeInfo,ansiStrData);
End;
tkWString :
begin
wideStrData := WideString(AData);
PutWideStr(AName,ATypeInfo,wideStrData);
end;
{$IFDEF WST_UNICODESTRING}
tkUString :
begin
unicodeStrData := UnicodeString(AData);
PutUnicodeStr(AName,ATypeInfo,unicodeStrData);
end;
{$ENDIF WST_UNICODESTRING}
tkInt64 :
Begin
int64Data := Int64(AData);
PutInt64(AName,ATypeInfo,int64Data);
End;
{$IFDEF HAS_QWORD}
tkQWord :
Begin
uint64Data := QWord(AData);
PutUInt64(AName,ATypeInfo,uint64Data);
End;
{$ENDIF HAS_QWORD}
tkClass :
Begin
objData := TObject(AData);
PutObj(AName,ATypeInfo,objData);
End;
tkRecord :
begin
PutRecord(AName,ATypeInfo,Pointer(@AData));
end;
{$IFDEF FPC}
tkBool :
Begin
boolData := Boolean(AData);
PutBool(AName,ATypeInfo,boolData);
End;
{$ENDIF}
tkInteger, tkEnumeration :
begin
{$IFNDEF FPC}
if ( ATypeInfo^.Kind = tkEnumeration ) and
( GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean) )
then begin
boolData := Boolean(AData);
PutBool(AName,ATypeInfo,boolData);
end else begin
{$ENDIF}
enumData := 0;
Case GetTypeData(ATypeInfo)^.OrdType Of
otSByte : enumData := ShortInt(AData);
otUByte : enumData := Byte(AData);
otSWord : enumData := SmallInt(AData);
otUWord : enumData := Word(AData);
otSLong : enumData := LongInt(AData);
otULong : enumData := LongWord(AData);
End;
If ( ATypeInfo^.Kind = tkInteger ) Then
PutInt(AName,ATypeInfo,enumData)
Else
PutEnum(AName,ATypeInfo,enumData);
{$IFNDEF FPC}
end;
{$ENDIF}
end;
tkFloat :
Begin
floatDt := 0;
Case GetTypeData(ATypeInfo)^.FloatType Of
ftSingle : floatDt := Single(AData);
ftDouble : floatDt := Double(AData);
ftExtended : floatDt := Extended(AData);
ftCurr : floatDt := Currency(AData);
ftComp : floatDt := Comp(AData);
End;
PutFloat(AName,ATypeInfo,floatDt);
End;
End;
end;
procedure TBaseBinaryFormatter.Put(
const ANameSpace : string;
const AName : String;
const ATypeInfo : PTypeInfo;
const AData
);
begin
Put(AName,ATypeInfo,AData);
end;
procedure TBaseBinaryFormatter.PutScopeInnerValue(
const ATypeInfo : PTypeInfo;
const AData
);
var
int64SData : Int64;
{$IFDEF HAS_QWORD}
uint64Data : QWord;
{$ENDIF HAS_QWORD}
strData : string;
boolData : Boolean;
enumData : TEnumData;
floatDt : TFloat_Extended_10;
wideStrData : WideString;
{$IFDEF WST_UNICODESTRING}
unicodeStrData : UnicodeString;
{$ENDIF WST_UNICODESTRING}
ansiCharData : AnsiChar;
wideCharData : WideChar;
begin
CheckScope();
case ATypeInfo^.Kind of
tkChar :
begin
ansiCharData := AnsiChar(AData);
StackTop().CreateInnerBuffer(dtAnsiChar)^.AnsiCharData:= ansiCharData;
end;
tkWChar :
begin
wideCharData := WideChar(AData);
StackTop().CreateInnerBuffer(dtWideChar)^.WideCharData:= wideCharData;
end;
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
begin
strData := AnsiString(AData);
StackTop().CreateInnerBuffer(dtAnsiString)^.AnsiStrData^.Data := strData;
end;
tkWString :
begin
wideStrData := WideString(AData);
StackTop().CreateInnerBuffer(dtWideString)^.WideStrData^.Data := wideStrData;
end;
{$IFDEF WST_UNICODESTRING}
tkUString :
begin
unicodeStrData := UnicodeString(AData);
StackTop().CreateInnerBuffer(dtUnicodeString)^.UnicodeStrData^.Data := unicodeStrData;
end;
{$ENDIF WST_UNICODESTRING}
tkInt64 :
begin
int64SData := Int64(AData);
StackTop().CreateInnerBuffer(dtInt64S)^.Int64S := int64SData;
end;
{$IFDEF HAS_QWORD}
tkQWord :
begin
uint64Data := QWord(AData);
StackTop().CreateInnerBuffer(dtInt64U)^.Int64U := uint64Data;
end;
{$ENDIF HAS_QWORD}
tkClass, tkRecord :
begin
raise EBinaryFormatterException.Create(SERR_InnerScopeMustBeSimpleType);
end;
{$IFDEF FPC}
tkBool :
begin
boolData := Boolean(AData);
StackTop().CreateInnerBuffer(dtBool)^.BoolData := boolData;
end;
{$ENDIF}
tkInteger :
begin
enumData := 0;
case GetTypeData(ATypeInfo)^.OrdType of
otSByte :
begin
enumData := ShortInt(AData);
StackTop().CreateInnerBuffer(dtInt8S)^.Int8S := enumData;
end;
otUByte :
begin
enumData := Byte(AData);
StackTop().CreateInnerBuffer(dtInt8U)^.Int8U := enumData;
end;
otSWord :
begin
enumData := SmallInt(AData);
StackTop().CreateInnerBuffer(dtInt16S)^.Int16S := enumData;
end;
otUWord :
begin
enumData := Word(AData);
StackTop().CreateInnerBuffer(dtInt16U)^.Int16U := enumData;
end;
otSLong :
begin
enumData := LongInt(AData);
StackTop().CreateInnerBuffer(dtInt32S)^.Int32S := enumData;
end;
otULong :
begin
enumData := LongWord(AData);
StackTop().CreateInnerBuffer(dtInt32U)^.Int32U := enumData;
end;
end;
end;
tkEnumeration :
begin
{$IFNDEF FPC}
if ( ATypeInfo^.Kind = tkEnumeration ) and
( GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean) )
then begin
boolData := Boolean(AData);
StackTop().CreateInnerBuffer(dtBool)^.BoolData := boolData;
end else begin
{$ENDIF}
enumData := 0;
case GetTypeData(ATypeInfo)^.OrdType of
otSByte : enumData := ShortInt(AData);
otUByte : enumData := Byte(AData);
otSWord : enumData := SmallInt(AData);
otUWord : enumData := Word(AData);
otSLong : enumData := LongInt(AData);
otULong : enumData := LongWord(AData);
end;
StackTop().CreateInnerBuffer(dtEnum)^.EnumData := enumData;
{$IFNDEF FPC}
end;
{$ENDIF}
end;
tkFloat :
begin
floatDt := 0;
case GetTypeData(ATypeInfo)^.FloatType of
ftSingle :
begin
floatDt := Single(AData);
StackTop().CreateInnerBuffer(dtSingle)^.SingleData := floatDt;
end;
ftDouble :
begin
floatDt := Double(AData);
StackTop().CreateInnerBuffer(dtDouble)^.DoubleData := floatDt;
end;
ftExtended :
begin
floatDt := Extended(AData);
StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt;
end;
ftCurr :
begin
floatDt := Currency(AData);
StackTop().CreateInnerBuffer(dtExtended)^.CurrencyData := floatDt;
end;
ftComp :
begin
floatDt := Comp(AData);
StackTop().CreateInnerBuffer(dtCurrency)^.CurrencyData := floatDt;
end;
else
StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt;
end;
end;
end;
end;
function TBaseBinaryFormatter.Get(
const ATypeInfo: PTypeInfo;
var AName: String;
var AData
) : Boolean;
Var
int64Data : Int64;
{$IFDEF HAS_QWORD}
uint64Data : QWOrd;
{$ENDIF HAS_QWORD}
strData : AnsiString;
objData : TObject;
boolData : Boolean;
enumData : TEnumData;
floatDt : TFloat_Extended_10;
recObject : Pointer;
wideStrData : WideString;
{$IFDEF WST_UNICODESTRING}
unicodeStrData : UnicodeString;
{$ENDIF WST_UNICODESTRING}
ansiCharData : AnsiChar;
wideCharData : WideChar;
begin
Case ATypeInfo^.Kind Of
tkInt64 :
Begin
int64Data := 0;
Result := GetInt64(ATypeInfo,AName,int64Data);
if Result then
Int64(AData) := int64Data;
End;
{$IFDEF HAS_QWORD}
tkQWord :
Begin
uint64Data := 0;
Result := GetUInt64(ATypeInfo,AName,uint64Data);
if Result then
QWord(AData) := uint64Data;
End;
{$ENDIF HAS_QWORD}
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
Begin
strData := '';
Result := GetAnsiStr(ATypeInfo,AName,strData);
if Result then
AnsiString(AData) := strData;
End;
tkWString :
begin
wideStrData := '';
Result := GetWideStr(ATypeInfo,AName,wideStrData);
if Result then
WideString(AData) := wideStrData;
end;
{$IFDEF WST_UNICODESTRING}
tkUString :
begin
unicodeStrData := '';
Result := GetUnicodeStr(ATypeInfo,AName,unicodeStrData);
if Result then
UnicodeString(AData) := unicodeStrData;
end;
{$ENDIF WST_UNICODESTRING}
tkClass :
Begin
objData := TObject(AData);
Result := GetObj(ATypeInfo,AName,objData);
if Result then
TObject(AData) := objData;
End;
tkRecord :
begin
recObject := Pointer(@AData);
Result := GetRecord(ATypeInfo,AName,recObject);
end;
{$IFDEF FPC}
tkBool :
Begin
boolData := False;
Result := GetBool(ATypeInfo,AName,boolData);
if Result then
Boolean(AData) := boolData;
End;
{$ENDIF}
tkChar :
begin
ansiCharData := #0;
Result := GetAnsiChar(ATypeInfo,AName,ansiCharData);
if Result then
AnsiChar(AData) := ansiCharData;
end;
tkWChar :
begin
wideCharData := #0;
Result := GetWideChar(ATypeInfo,AName,wideCharData);
if Result then
WideChar(AData) := wideCharData;
end;
tkInteger, tkEnumeration :
Begin
{$IFNDEF FPC}
if ( ATypeInfo^.Kind = tkEnumeration ) and
( GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean) )
then begin
boolData := False;
Result := GetBool(ATypeInfo,AName,boolData);
if Result then
Boolean(AData) := boolData;
end else begin
{$ENDIF}
enumData := 0;
If ( ATypeInfo^.Kind = tkInteger ) Then
Result := GetInt(ATypeInfo,AName,enumData)
Else
Result := GetEnum(ATypeInfo,AName,enumData);
if Result then begin
Case GetTypeData(ATypeInfo)^.OrdType Of
otSByte : ShortInt(AData) := enumData;
otUByte : Byte(AData) := enumData;
otSWord : SmallInt(AData) := enumData;
otUWord : Word(AData) := enumData;
otSLong : LongInt(AData) := enumData;
otULong : LongWord(AData) := enumData;
End;
end;
{$IFNDEF FPC}
end;
{$ENDIF}
End;
tkFloat :
Begin
floatDt := 0;
Result := GetFloat(ATypeInfo,AName,floatDt);
if Result then begin
Case GetTypeData(ATypeInfo)^.FloatType Of
ftSingle : Single(AData) := floatDt;
ftDouble : Double(AData) := floatDt;
ftExtended : Extended(AData) := floatDt;
ftCurr : Currency(AData) := floatDt;
{$IFDEF HAS_COMP}
ftComp : Comp(AData) := floatDt;
{$ENDIF}
End;
end
end;
else
Result := False;
end;
end;
function TBaseBinaryFormatter.Get(
const ATypeInfo : PTypeInfo;
const ANameSpace : string;
var AName : string;
var AData
) : Boolean;
begin
Result := Get(ATypeInfo,AName,AData);
end;
procedure TBaseBinaryFormatter.GetScopeInnerValue(
const ATypeInfo : PTypeInfo;
var AData
);
Var
dataBuffer : PDataBuffer;
begin
CheckScope();
dataBuffer := StackTop().GetInnerBuffer();
Case ATypeInfo^.Kind Of
tkChar : AnsiChar(AData) := dataBuffer^.AnsiCharData ;
tkWChar : WideChar(AData) := dataBuffer^.WideCharData ;
tkInt64 : Int64(AData) := dataBuffer^.Int64S;
{$IFDEF HAS_QWORD}
tkQWord : QWord(AData) := dataBuffer^.Int64U;
{$ENDIF HAS_QWORD}
tkLString
{$IFDEF FPC},
tkAString
{$ENDIF} :
begin
case dataBuffer^.DataType of
dtUnicodeString : AnsiString(AData) := dataBuffer^.UnicodeStrData^.Data;
dtWideString : AnsiString(AData) := dataBuffer^.WideStrData^.Data;
else
AnsiString(AData) := dataBuffer^.AnsiStrData^.Data;
end;
end;
tkWString :
begin
case dataBuffer^.DataType of
dtUnicodeString : WideString(AData) := dataBuffer^.UnicodeStrData^.Data;
dtAnsiString : WideString(AData) := dataBuffer^.AnsiStrData^.Data;
else
WideString(AData) := dataBuffer^.WideStrData^.Data;
end;
end;
{$IFDEF WST_UNICODESTRING}
tkUString :
begin
case dataBuffer^.DataType of
dtAnsiString : UnicodeString(AData) := dataBuffer^.AnsiStrData^.Data;
dtWideString : UnicodeString(AData) := dataBuffer^.WideStrData^.Data;
else
UnicodeString(AData) := dataBuffer^.UnicodeStrData^.Data;
end;
end;
{$ENDIF WST_UNICODESTRING}
tkClass, tkRecord : raise EBinaryFormatterException.Create(SERR_InnerScopeMustBeSimpleType);
{$IFDEF FPC}
tkBool : Boolean(AData) := dataBuffer^.BoolData;
{$ENDIF}
tkInteger :
begin
case GetTypeData(ATypeInfo)^.OrdType Of
otSByte : ShortInt(AData) := dataBuffer^.Int8S;
otUByte : Byte(AData) := dataBuffer^.Int8U;
otSWord : SmallInt(AData) := dataBuffer^.Int16S;
otUWord : Word(AData) := dataBuffer^.Int16U;
otSLong : LongInt(AData) := dataBuffer^.Int32S;
otULong : LongWord(AData) := dataBuffer^.Int32U;
end;
end;
tkEnumeration :
begin
{$IFNDEF FPC}
if ( ATypeInfo^.Kind = tkEnumeration ) and
( GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean) )
then begin
Boolean(AData) := dataBuffer^.BoolData;
end else begin
{$ENDIF}
case GetTypeData(ATypeInfo)^.OrdType Of
otSByte : ShortInt(AData) := dataBuffer^.EnumData;
otUByte : Byte(AData) := dataBuffer^.EnumData;
otSWord : SmallInt(AData) := dataBuffer^.EnumData;
otUWord : Word(AData) := dataBuffer^.EnumData;
otSLong : LongInt(AData) := dataBuffer^.EnumData;
otULong : LongWord(AData) := dataBuffer^.EnumData;
end;
{$IFNDEF FPC}
end;
{$ENDIF}
end;
tkFloat :
begin
case GetTypeData(ATypeInfo)^.FloatType of
ftSingle : Single(AData) := dataBuffer^.SingleData;
ftDouble : Double(AData) := dataBuffer^.DoubleData;
ftExtended : Extended(AData) := dataBuffer^.ExtendedData;
ftCurr : Currency(AData) := dataBuffer^.CurrencyData;
{$IFDEF HAS_COMP}
else
Comp(AData) := dataBuffer^.ExtendedData;
{$ENDIF}
end;
end;
end;
end;
function TBaseBinaryFormatter.ReadBuffer (const AName : string; out AResBuffer : string) : Boolean;
Var
locStore : IDataStore;
bffr : PDataBuffer;
locName : string;
locStream : TStringStream;
begin
locName := AName;
Result := GetDataBuffer(locName,bffr);
if Result then begin
locStream := TStringStream.Create('');
try
locStore := CreateBinaryWriter(locStream);
SaveObjectToStream(bffr,locStore);
AResBuffer := locStream.DataString;
finally
locStream.Free();
end;
end;
end;
procedure TBaseBinaryFormatter.SaveToStream(AStream: TStream);
Var
locStore : IDataStore;
begin
locStore := CreateBinaryWriter(AStream);
SaveObjectToStream(FRootData,locStore);
end;
procedure TBaseBinaryFormatter.LoadFromStream(AStream: TStream);
Var
locRdr : IDataStoreReader;
tmpRoot : PDataBuffer;
begin
locRdr := CreateBinaryReader(AStream);
tmpRoot := LoadObjectFromStream(locRdr);
ClearStack();
ClearObj(FRootData);
Freemem(FRootData);
FRootData := tmpRoot;
PushStack(FRootData,stObject);
end;
procedure TBaseBinaryFormatter.Error(const AMsg: string);
begin
Raise EBinaryFormatterException.Create(AMsg);
end;
procedure TBaseBinaryFormatter.Error(const AMsg: string;const AArgs: array of const);
begin
Raise EBinaryFormatterException.CreateFmt(AMsg,AArgs);
end;
constructor TBaseBinaryFormatter.Create();
begin
FRootData := CreateObjBuffer(dtObject,sROOT);
FStack := TObjectStack.Create();
PushStack(FRootData,stObject);
end;
destructor TBaseBinaryFormatter.Destroy();
begin
ClearStack();
FreeAndNil(FStack);
ClearObj(FRootData);
Freemem(FRootData);
inherited Destroy();
end;
function TBaseBinaryFormatter.GetFormatName() : string;
begin
Result := sBINARY_FORMAT_NAME;
end;
function TBaseBinaryFormatter.GetPropertyManager() : IPropertyManager;
begin
If Not Assigned(FPropMngr) Then
FPropMngr := TPublishedPropertyManager.Create(Self);
Result := FPropMngr;
end;
procedure TBaseBinaryFormatter.WriteBuffer(const AValue: string);
var
locStore : IDataStoreReader;
bffr : PDataBuffer;
locStream : TStringStream;
begin
CheckScope();
locStream := TStringStream.Create(AValue);
try
locStream.Position := 0;
locStore := CreateBinaryReader(locStream);
bffr := LoadObjectFromStream(locStore);
AddObj(StackTop.ScopeObject,bffr);
finally
locStream.Free();
end;
end;
{ TArrayStackItem }
constructor TArrayStackItem.Create(const AScopeObject: PDataBuffer);
begin
Inherited Create(AScopeObject,stArray);
FIndex := 0;
end;
function TArrayStackItem.GetItemCount(): Integer;
begin
Result := ScopeObject^.ArrayData^.Count;
end;
function TArrayStackItem.Find(var AName: TDataName): PDataBuffer;
begin
If ( FIndex >= 0 ) And ( FIndex < ScopeObject^.ArrayData^.Count ) Then
Result := ScopeObject^.ArrayData^.Items^[FIndex]
Else
Raise EBinaryFormatterException.CreateFmt(SERR_IndexOutOfBound,[FIndex]);
Inc(FIndex);
end;
function TArrayStackItem.GetByIndex(const AIndex: Integer): PDataBuffer;
begin
If ( AIndex >= 0 ) And ( AIndex < ScopeObject^.ArrayData^.Count ) Then
Result := ScopeObject^.ArrayData^.Items^[AIndex]
Else
Raise EBinaryFormatterException.CreateFmt(SERR_IndexOutOfBound,[AIndex]);
end;
function TArrayStackItem.CreateBuffer(
const AName : String;
const ADataType : TDataType
): PDataBuffer;
begin
If ( FIndex >= 0 ) And ( FIndex < ScopeObject^.ArrayData^.Count ) Then
Result := CreateObjBuffer(ADataType,AName,Nil)
Else
Raise EBinaryFormatterException.CreateFmt(SERR_IndexOutOfBound,[FIndex]);
ScopeObject^.ArrayData^.Items^[FIndex] := Result;
Inc(FIndex);
end;
{$WARNINGS OFF}
function TArrayStackItem.CreateInnerBuffer(const ADataType: TDataType): PDataBuffer;
begin
raise EBinaryFormatterException.CreateFmt(SERR_UnsupportedOperation,['TArrayStackItem.CreateInnerBuffer']);
end;
function TArrayStackItem.GetInnerBuffer(): PDataBuffer;
begin
raise EBinaryFormatterException.CreateFmt(SERR_UnsupportedOperation,['TArrayStackItem.GetInnerBuffer']);
end;
{$WARNINGS ON}
procedure TArrayStackItem.NilCurrentScope();
begin
end;
function TArrayStackItem.IsCurrentScopeNil(): Boolean;
begin
Result := False;
end;
function TArrayStackItem.GetScopeItemNames(const AReturnList: TStrings): Integer;
var
locBuffer : PDataBufferList;
i : Integer;
begin
AReturnList.Clear();
if Assigned(ScopeObject) and ( ScopeObject^.ArrayData^.Count > 0 ) then begin
locBuffer := ScopeObject^.ArrayData^.Items;
for i := 0 to Pred(ScopeObject^.ArrayData^.Count) do begin
AReturnList.Add(locBuffer^[i]^.Name);
end;
end;
Result := AReturnList.Count;
end;
end.
Reference in New Issue View Git Blame Copy Permalink