You've already forked lazarus-ccr
1069954eba
- Field may be hidden by calling SetFieldSerializationVisibility()
- Field may be mapped to XML Attribute by calling RegisterAttributeProperty()
Some methods and routines have been marked "inline". By default the "inline" modifier is not enable. To enable it
uncomment the "//{$DEFINE USE_INLINE}" line in wst_global.inc.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@244 8e941d3f-bd1b-0410-a28a-d453659cc2b4
1659 lines
46 KiB
ObjectPascal
1659 lines
46 KiB
ObjectPascal
{ 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
|
|
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 = AnsiString;
|
|
TDataType = (
|
|
dtInt8U, dtInt8S,
|
|
dtInt16U, dtInt16S,
|
|
dtInt32U, dtInt32S,
|
|
dtInt64U, dtInt64S,
|
|
dtBool, dtEnum,
|
|
dtSingle, dtDouble, dtExtended, dtCurrency,
|
|
dtString,
|
|
dtObject, dtArray
|
|
);
|
|
|
|
PStringBuffer = ^TStringBuffer;
|
|
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 );
|
|
dtEnum : ( EnumData : TEnumData );
|
|
dtSingle : ( SingleData : TFloat_Single_4 );
|
|
dtDouble : ( DoubleData : TFloat_Double_8 );
|
|
dtExtended : ( ExtendedData : TFloat_Extended_10 );
|
|
dtCurrency : ( CurrencyData : TFloat_Currency_8 );
|
|
|
|
dtString : ( StrData : PStringBuffer );
|
|
dtObject : ( ObjectData : PObjectBuffer );
|
|
dtArray : ( ArrayData : PArrayBuffer );
|
|
End;
|
|
|
|
TStringBuffer = Record
|
|
Data : String;
|
|
End;
|
|
|
|
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;
|
|
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;
|
|
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;
|
|
End;
|
|
|
|
{ TBaseBinaryFormatter }
|
|
|
|
TBaseBinaryFormatter = class(TSimpleFactoryItem,IFormatterBase)
|
|
private
|
|
FRootData : PDataBuffer;
|
|
FStack : TObjectStack;
|
|
FSerializationStyle : TSerializationStyle;
|
|
{$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 PutStr(
|
|
Const AName : String;
|
|
Const ATypeInfo : PTypeInfo;
|
|
Const AData : String
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
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 PutInt64(
|
|
Const AName : String;
|
|
Const ATypeInfo : PTypeInfo;
|
|
Const AData : Int64
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
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):PDataBuffer;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetEnum(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : TEnumData
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetBool(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : Boolean
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetFloat(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : TFloat_Extended_10
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetInt(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : TInt64S
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetInt64(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : Int64
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetStr(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : String
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetObj(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData : TObject
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure GetRecord(
|
|
const ATypeInfo : PTypeInfo;
|
|
var AName : String;
|
|
var AData : Pointer
|
|
);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
public
|
|
constructor Create();override;
|
|
destructor Destroy();override;
|
|
|
|
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;
|
|
procedure EndScopeRead();
|
|
|
|
procedure BeginHeader();
|
|
procedure EndHeader();
|
|
|
|
property CurrentScope : String Read GetCurrentScope;
|
|
|
|
procedure Put(
|
|
Const AName : String;
|
|
Const ATypeInfo : PTypeInfo;
|
|
Const AData
|
|
);
|
|
procedure PutScopeInnerValue(
|
|
const ATypeInfo : PTypeInfo;
|
|
const AData
|
|
);
|
|
procedure Get(
|
|
Const ATypeInfo : PTypeInfo;
|
|
Var AName : String;
|
|
Var AData
|
|
);
|
|
procedure GetScopeInnerValue(
|
|
const ATypeInfo : PTypeInfo;
|
|
var AData
|
|
);
|
|
function ReadBuffer(const AName : string) : 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);
|
|
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
|
|
|
|
{$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) );
|
|
|
|
dtString : APrinterProc( s + ARoot^.Name + ' = ' + ARoot^.StrData^.Data );
|
|
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('Invalid array acces : %d',[AIndex])
|
|
End Else Begin
|
|
Raise EBinaryFormatterException.CreateFmt('Invalid data type in this context : %d',[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
|
|
dtString :
|
|
Begin
|
|
i := SizeOf(TStringBuffer);
|
|
Result^.StrData := wst_GetMem(i);
|
|
FillChar(Result^.StrData^,i,#0);
|
|
Result^.StrData^.Data := '';
|
|
End;
|
|
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);
|
|
Result := nil;
|
|
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);
|
|
Result := nil;
|
|
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.WriteStr(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);
|
|
|
|
dtString : ADest.WriteStr(ARoot^.StrData^.Data);
|
|
dtBool : ADest.WriteBool(ARoot^.BoolData);
|
|
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.ReadStr();
|
|
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();
|
|
|
|
dtString : Result^.StrData^.Data := AStoreRdr.ReadStr();
|
|
dtBool : Result^.BoolData := AStoreRdr.ReadBool();
|
|
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 ClearObjectBuffer(var ABuffer : PObjectBuffer);
|
|
var
|
|
p,q : PObjectBufferItem;
|
|
begin
|
|
if Assigned(ABuffer) then begin
|
|
if Assigned(ABuffer^.Attributes) then
|
|
ClearObjectBuffer(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);
|
|
ABuffer^.InnerData := nil;
|
|
end;
|
|
//ABuffer^.Head := nil;
|
|
//ABuffer^.Last := nil;
|
|
Freemem(ABuffer);
|
|
ABuffer := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure ClearObj(const AOwner: PDataBuffer);
|
|
Var
|
|
i , j: Integer;
|
|
eltLen : Integer;
|
|
Begin
|
|
AOwner^.Name := '';
|
|
Case AOwner^.DataType Of
|
|
dtString :
|
|
Begin
|
|
AOwner^.StrData^.Data := '';
|
|
Freemem(AOwner^.StrData);
|
|
AOwner^.StrData := Nil;
|
|
End;
|
|
dtObject :
|
|
Begin
|
|
ClearObjectBuffer(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;
|
|
ClearObjectBuffer(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('Invalid index access : %d',[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;
|
|
|
|
//----------------------------------------------------------------
|
|
{ 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('There is no scope.');
|
|
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.PutStr(
|
|
const AName : String;
|
|
const ATypeInfo : PTypeInfo;
|
|
const AData : String
|
|
);
|
|
begin
|
|
StackTop().CreateBuffer(AName,dtString)^.StrData^.Data := AData;
|
|
end;
|
|
|
|
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.PutInt64(
|
|
const AName: String;
|
|
const ATypeInfo: PTypeInfo;
|
|
const AData: Int64
|
|
);
|
|
begin
|
|
StackTop().CreateBuffer(AName,dtInt64S)^.Int64S := AData;
|
|
end;
|
|
|
|
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): PDataBuffer;
|
|
begin
|
|
Result := StackTop().Find(AName);
|
|
If Not Assigned(Result) Then
|
|
Error('Param not found : "%s"',[AName]);
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetEnum(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: TEnumData
|
|
);
|
|
begin
|
|
AData := GetDataBuffer(AName)^.EnumData;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetBool(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: Boolean
|
|
);
|
|
begin
|
|
AData := GetDataBuffer(AName)^.BoolData;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetFloat(
|
|
const ATypeInfo : PTypeInfo;
|
|
var AName : String;
|
|
var AData : TFloat_Extended_10
|
|
);
|
|
Var
|
|
t : PDataBuffer;
|
|
begin
|
|
t := GetDataBuffer(AName);
|
|
Case GetTypeData(ATypeInfo)^.FloatType Of
|
|
ftSingle : AData := t^.SingleData;
|
|
ftDouble : AData := t^.DoubleData;
|
|
ftExtended : AData := t^.ExtendedData;
|
|
ftCurr : AData := t^.CurrencyData;
|
|
Else
|
|
AData := t^.ExtendedData;
|
|
End;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetInt(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: TInt64S
|
|
);
|
|
Var
|
|
t : PDataBuffer;
|
|
begin
|
|
t := GetDataBuffer(AName);
|
|
Case GetTypeData(ATypeInfo)^.OrdType Of
|
|
otSByte : AData := t^.Int8S;
|
|
otUByte : AData := t^.Int8U;
|
|
otSWord : AData := t^.Int16S;
|
|
otUWord : AData := t^.Int16U;
|
|
otSLong : AData := t^.Int32S;
|
|
otULong : AData := t^.Int32U;
|
|
Else
|
|
Assert(False);
|
|
End;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetInt64(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: Int64
|
|
);
|
|
begin
|
|
AData := GetDataBuffer(AName)^.Int64S;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetStr(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: String
|
|
);
|
|
begin
|
|
AData := GetDataBuffer(AName)^.StrData^.Data;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetObj(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData: TObject
|
|
);
|
|
begin
|
|
TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Load(AData, Self,AName,ATypeInfo);
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetRecord(
|
|
const ATypeInfo : PTypeInfo;
|
|
var AName : String;
|
|
var AData : Pointer
|
|
);
|
|
begin
|
|
TRemotableRecordEncoder.Load(AData, Self,AName,ATypeInfo);
|
|
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('Invalid array bounds.');
|
|
i := ABounds[0];
|
|
j := ABounds[1];
|
|
k := ( j - i + 1 );
|
|
If ( k < 0 ) Then
|
|
Raise EBinaryFormatterException.Create('Invalid array bounds.');
|
|
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: TDataName;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 not Assigned(locNode) then begin
|
|
Error('Scope not found : "%s"',[AScopeName]);
|
|
end;
|
|
PushStack(locNode,stObject);
|
|
Result := StackTop().GetItemCount();
|
|
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 not Assigned(locNode) then begin
|
|
Error('Scope not found : "%s"',[AScopeName]);
|
|
end;
|
|
PushStack(locNode,stArray);
|
|
Result := StackTop().GetItemCount();
|
|
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;
|
|
strData : string;
|
|
objData : TObject;
|
|
boolData : Boolean;
|
|
enumData : TEnumData;
|
|
floatDt : TFloat_Extended_10;
|
|
begin
|
|
Case ATypeInfo^.Kind Of
|
|
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
|
|
Begin
|
|
strData := String(AData);
|
|
PutStr(AName,ATypeInfo,strData);
|
|
End;
|
|
tkInt64{$IFDEF FPC},tkQWord{$ENDIF} :
|
|
Begin
|
|
int64Data := Int64(AData);
|
|
PutInt64(AName,ATypeInfo,int64Data);
|
|
End;
|
|
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.PutScopeInnerValue(
|
|
const ATypeInfo : PTypeInfo;
|
|
const AData
|
|
);
|
|
var
|
|
int64SData : Int64;
|
|
{$IFDEF FPC}int64UData : QWord;{$ENDIF}
|
|
strData : string;
|
|
boolData : Boolean;
|
|
enumData : TEnumData;
|
|
floatDt : TFloat_Extended_10;
|
|
begin
|
|
CheckScope();
|
|
case ATypeInfo^.Kind of
|
|
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
|
|
begin
|
|
strData := string(AData);
|
|
StackTop().CreateInnerBuffer(dtString)^.StrData^.Data := strData;
|
|
end;
|
|
tkInt64 :
|
|
begin
|
|
int64SData := Int64(AData);
|
|
StackTop().CreateInnerBuffer(dtInt64S)^.Int64S := int64SData;
|
|
end;
|
|
{$IFDEF FPC}
|
|
tkQWord :
|
|
begin
|
|
int64UData := QWord(AData);
|
|
StackTop().CreateInnerBuffer(dtInt64U)^.Int64U := int64UData;
|
|
end;
|
|
{$ENDIF}
|
|
tkClass :
|
|
begin
|
|
raise EBinaryFormatterException.Create('Inner Scope value must be a "simple type" value.');
|
|
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)^.ExtendedData := floatDt;
|
|
end;
|
|
ftComp :
|
|
begin
|
|
floatDt := Comp(AData);
|
|
StackTop().CreateInnerBuffer(dtCurrency)^.CurrencyData := floatDt;
|
|
end;
|
|
else
|
|
StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.Get(
|
|
const ATypeInfo: PTypeInfo;
|
|
var AName: String;
|
|
var AData
|
|
);
|
|
Var
|
|
int64Data : Int64;
|
|
strData : string;
|
|
objData : TObject;
|
|
boolData : Boolean;
|
|
enumData : TEnumData;
|
|
floatDt : TFloat_Extended_10;
|
|
recObject : Pointer;
|
|
begin
|
|
Case ATypeInfo^.Kind Of
|
|
tkInt64{$IFDEF FPC},tkQWord{$ENDIF} :
|
|
Begin
|
|
int64Data := 0;
|
|
GetInt64(ATypeInfo,AName,int64Data);
|
|
Int64(AData) := int64Data;
|
|
End;
|
|
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
|
|
Begin
|
|
strData := '';
|
|
GetStr(ATypeInfo,AName,strData);
|
|
String(AData) := strData;
|
|
End;
|
|
tkClass :
|
|
Begin
|
|
objData := TObject(AData);
|
|
GetObj(ATypeInfo,AName,objData);
|
|
TObject(AData) := objData;
|
|
End;
|
|
tkRecord :
|
|
begin
|
|
recObject := Pointer(@AData);
|
|
GetRecord(ATypeInfo,AName,recObject);
|
|
end;
|
|
{$IFDEF FPC}
|
|
tkBool :
|
|
Begin
|
|
boolData := False;
|
|
GetBool(ATypeInfo,AName,boolData);
|
|
Boolean(AData) := boolData;
|
|
End;
|
|
{$ENDIF}
|
|
tkInteger, tkEnumeration :
|
|
Begin
|
|
{$IFNDEF FPC}
|
|
if ( ATypeInfo^.Kind = tkEnumeration ) and
|
|
( GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
boolData := False;
|
|
GetBool(ATypeInfo,AName,boolData);
|
|
Boolean(AData) := boolData;
|
|
end else begin
|
|
{$ENDIF}
|
|
enumData := 0;
|
|
If ( ATypeInfo^.Kind = tkInteger ) Then
|
|
GetInt(ATypeInfo,AName,enumData)
|
|
Else
|
|
GetEnum(ATypeInfo,AName,enumData);
|
|
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;
|
|
{$IFNDEF FPC}
|
|
end;
|
|
{$ENDIF}
|
|
End;
|
|
tkFloat :
|
|
Begin
|
|
floatDt := 0;
|
|
GetFloat(ATypeInfo,AName,floatDt);
|
|
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;
|
|
end;
|
|
|
|
procedure TBaseBinaryFormatter.GetScopeInnerValue(
|
|
const ATypeInfo : PTypeInfo;
|
|
var AData
|
|
);
|
|
Var
|
|
dataBuffer : PDataBuffer;
|
|
begin
|
|
CheckScope();
|
|
dataBuffer := StackTop().GetInnerBuffer();
|
|
Case ATypeInfo^.Kind Of
|
|
tkInt64 : Int64(AData) := dataBuffer^.Int64S;
|
|
{$IFDEF FPC}
|
|
tkQWord : QWord(AData) := dataBuffer^.Int64U;
|
|
{$ENDIF}
|
|
|
|
tkLString
|
|
{$IFDEF FPC},
|
|
tkAString
|
|
{$ENDIF} : string(AData) := dataBuffer^.StrData^.Data;
|
|
|
|
tkClass : raise EBinaryFormatterException.Create('Inner Scope value must be a "simple type" value.');
|
|
{$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 ) : string;
|
|
Var
|
|
locStore : IDataStore;
|
|
bffr : PDataBuffer;
|
|
locName : string;
|
|
locStream : TStringStream;
|
|
begin
|
|
locName := AName;
|
|
bffr := GetDataBuffer(locName);
|
|
locStream := TStringStream.Create('');
|
|
try
|
|
locStore := CreateBinaryWriter(locStream);
|
|
SaveObjectToStream(bffr,locStore);
|
|
Result := locStream.DataString;
|
|
finally
|
|
locStream.Free();
|
|
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;
|
|
|
|
{ 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('Invalid array index : %d',[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('Invalid array index : %d',[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('Invalid array index : %d',[FIndex]);
|
|
ScopeObject^.ArrayData^.Items^[FIndex] := Result;
|
|
Inc(FIndex);
|
|
end;
|
|
|
|
function TArrayStackItem.CreateInnerBuffer(const ADataType: TDataType): PDataBuffer;
|
|
begin
|
|
raise EBinaryFormatterException.Create('Array do not support "inner value" feature.');
|
|
end;
|
|
|
|
function TArrayStackItem.GetInnerBuffer(): PDataBuffer;
|
|
begin
|
|
raise EBinaryFormatterException.Create('Array do not support "inner value" feature.');
|
|
end;
|
|
|
|
procedure TArrayStackItem.NilCurrentScope();
|
|
begin
|
|
end;
|
|
|
|
function TArrayStackItem.IsCurrentScopeNil(): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
end.
|