846ac6f77a
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@9637 8e941d3f-bd1b-0410-a28a-d453659cc2b4
7365 lines
216 KiB
ObjectPascal
7365 lines
216 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}
|
|
{$RANGECHECKS OFF}
|
|
|
|
unit base_service_intf;
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, TypInfo, Contnrs, syncobjs, semaphore, wst_types
|
|
{$IFDEF WST_DELPHI}
|
|
,Windows
|
|
{$ENDIF}
|
|
, date_utils;
|
|
|
|
const
|
|
stBase = 0;
|
|
stObject = stBase + 1;
|
|
stArray = stBase + 2;
|
|
|
|
sARRAY_ITEM = 'item';
|
|
sARRAY_STYLE = 'style';
|
|
|
|
// array style string
|
|
sScoped = 'scoped';
|
|
sEmbedded = 'embedded';
|
|
|
|
type
|
|
|
|
{ standart data types defines }
|
|
anyURI = type string;
|
|
token = type string;
|
|
language = type string;
|
|
NCName = type string;
|
|
nonNegativeInteger = type LongWord;
|
|
positiveInteger = type nonNegativeInteger;
|
|
float = Single;
|
|
{$IFNDEF WST_HAS_TDURATIONREMOTABLE}
|
|
duration = type string;
|
|
{$ENDIF WST_HAS_TDURATIONREMOTABLE}
|
|
{$IFNDEF WST_HAS_TTIMEREMOTABLE}
|
|
time = type string;
|
|
{$ENDIF WST_HAS_TTIMEREMOTABLE}
|
|
|
|
TScopeType = Integer;
|
|
TArrayStyle = ( asScoped, asEmbeded, asNone );
|
|
TInstanceOption = ( ioAlwaysSerialize );
|
|
TInstanceOptions = set of TInstanceOption;
|
|
THeaderDirection = ( hdOut, hdIn );
|
|
THeaderDirections = set of THeaderDirection;
|
|
const
|
|
AllHeaderDirection = [Low(THeaderDirection)..High(THeaderDirection)];
|
|
|
|
type
|
|
|
|
EServiceException = class(Exception) end;
|
|
EServiceExtensionException = class(Exception) end;
|
|
|
|
ETransportExecption = class(EServiceException)
|
|
private
|
|
FExtendedErrorInfo : string;
|
|
public
|
|
property ExtendedErrorInfo : string
|
|
read FExtendedErrorInfo write FExtendedErrorInfo;
|
|
end;
|
|
|
|
EBaseRemoteException = class(EServiceException)
|
|
private
|
|
FFaultCode: string;
|
|
FFaultString: string;
|
|
Published
|
|
property FaultCode : string Read FFaultCode Write FFaultCode;
|
|
property FaultString : string Read FFaultString Write FFaultString;
|
|
End;
|
|
|
|
EServiceConfigException = class(EServiceException)
|
|
end;
|
|
|
|
ETypeRegistryException = class(EServiceConfigException)
|
|
end;
|
|
|
|
IItemFactory = Interface;
|
|
IFormatterBase = Interface;
|
|
IFormatterRegistry = Interface;
|
|
|
|
TBaseRemotable = class;
|
|
THeaderBlock = class;
|
|
TSimpleContentHeaderBlock = class;
|
|
|
|
//Utility interface used to configure its parent.
|
|
IPropertyManager = Interface
|
|
['{A3A6B8F4-E50D-4956-B416-C642C72E4672}']
|
|
procedure SetProperty(Const AName,AValue:string);
|
|
procedure SetProperties(Const APropsStr:string);
|
|
function GetProperty(Const AName:String):string;
|
|
function GetPropertyNames(ADest : TStrings):Integer;
|
|
procedure Clear();
|
|
procedure Copy(ASource:IPropertyManager; Const AClearBefore : Boolean);
|
|
End;
|
|
|
|
IItemFactory = interface
|
|
['{38258BC0-CBE6-437B-B104-9A62475E53AC}']
|
|
function CreateInstance():IInterface;
|
|
end;
|
|
|
|
IItemFactoryEx = interface(IItemFactory)
|
|
['{66B77926-7E45-4780-8FFB-FB78625EDC1D}']
|
|
procedure ReleaseInstance(const AInstance : IInterface);
|
|
procedure DiscardInstance(const AInstance : IInterface);
|
|
function GetPropertyManager(
|
|
const APropertyGroup : string;
|
|
const ACreateIfNotExists : Boolean
|
|
):IPropertyManager;
|
|
end;
|
|
|
|
IFormatterRegistry = Interface
|
|
['{E4D69D2A-F0A5-43E1-8C56-B47E7AB5D1AF}']
|
|
function Find(const AFormatterName : string):IFormatterBase;
|
|
procedure Register(
|
|
const AFormatterName,
|
|
AContentType : string;
|
|
AFactory : IItemFactory
|
|
);
|
|
End;
|
|
|
|
ICallContext = Interface
|
|
['{855EB8E2-0700-45B1-B852-2101023200E0}']
|
|
procedure AddObjectToFree(const AObject : TObject);
|
|
procedure Clear();
|
|
function AddHeader(
|
|
const AHeader : THeaderBlock;
|
|
const AKeepOwnership : Boolean
|
|
):Integer;overload;
|
|
function AddHeader(
|
|
const AHeader : TBaseRemotable;
|
|
const AKeepOwnership : Boolean;
|
|
const AName : string = ''
|
|
):Integer;overload;
|
|
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
|
function GetHeader(const AIndex : Integer) : THeaderBlock;
|
|
procedure ClearHeaders(const ADirection : THeaderDirection);
|
|
function GetPropertyManager():IPropertyManager;
|
|
End;
|
|
|
|
TSerializationStyle = ( ssNodeSerialization, ssAttibuteSerialization );
|
|
|
|
IFormatterBase = Interface
|
|
['{2AB3BF54-B7D6-4C46-8245-133C8775E9C1}']
|
|
function GetPropertyManager():IPropertyManager;
|
|
function GetFormatName() : string;
|
|
procedure SetSerializationStyle(const ASerializationStyle : TSerializationStyle);
|
|
function GetSerializationStyle():TSerializationStyle;
|
|
function GetCurrentScope():string;
|
|
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();
|
|
property CurrentScope : String Read GetCurrentScope;
|
|
|
|
procedure BeginHeader();
|
|
procedure EndHeader();
|
|
|
|
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;
|
|
//Please use this method if and _only_ if you do not have another way achieve your aim!
|
|
procedure WriteBuffer(const AValue : string);
|
|
|
|
procedure SaveToStream(AStream : TStream);
|
|
procedure LoadFromStream(AStream : TStream);
|
|
|
|
// This procedures will raise exceptions!!!
|
|
procedure Error(Const AMsg:string);overload;
|
|
procedure Error(Const AMsg:string; Const AArgs : array of const);overload;
|
|
End;
|
|
|
|
{ TSimpleCallContext }
|
|
|
|
TSimpleCallContext = class(TInterfacedObject,ICallContext)
|
|
private
|
|
FHeaderList : TObjectList;
|
|
FFreeObjectList : TObjectList;
|
|
FPropertyManager : IPropertyManager;
|
|
protected
|
|
procedure AddObjectToFree(const AObject : TObject);
|
|
procedure Clear();
|
|
function AddHeader(
|
|
const AHeader : THeaderBlock;
|
|
const AKeepOwnership : Boolean
|
|
):Integer;overload;
|
|
function AddHeader(
|
|
const AHeader : TBaseRemotable;
|
|
const AKeepOwnership : Boolean;
|
|
const AName : string = ''
|
|
):Integer;overload;
|
|
function GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
|
function GetHeader(const AIndex : Integer) : THeaderBlock;
|
|
procedure ClearHeaders(const ADirection : THeaderDirection);
|
|
procedure FreeHeader(AHeader : THeaderBlock);
|
|
function GetPropertyManager():IPropertyManager;
|
|
public
|
|
constructor Create();
|
|
destructor Destroy();override;
|
|
end;
|
|
|
|
{ TBaseRemotable }
|
|
TBaseRemotableClass = class of TBaseRemotable;
|
|
TBaseRemotable = class(TPersistent)
|
|
Public
|
|
constructor Create();virtual;
|
|
destructor Destroy();override;
|
|
// This will free objects and arrays properties and set them to nil.
|
|
procedure FreeObjectProperties();virtual;
|
|
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
Const AName : String;
|
|
Const ATypeInfo : PTypeInfo
|
|
);virtual;abstract;
|
|
class procedure Load(
|
|
Var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);virtual;abstract;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;virtual;
|
|
function wstHasValue() : Boolean;virtual;
|
|
End;
|
|
|
|
TAbstractSimpleRemotableClass = class of TAbstractSimpleRemotable;
|
|
|
|
{ TAbstractSimpleRemotable }
|
|
|
|
TAbstractSimpleRemotable = class(TBaseRemotable) end;
|
|
|
|
{ TStringBufferRemotable }
|
|
|
|
TStringBufferRemotable = class(TAbstractSimpleRemotable)
|
|
private
|
|
FData : string;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
property Data : string read FData write FData;
|
|
end;
|
|
|
|
schema_Type = class(TStringBufferRemotable) end;
|
|
anyType_Type = class(TStringBufferRemotable) end;
|
|
|
|
{ TAbstractEncodedStringRemotable }
|
|
|
|
TAbstractEncodedStringRemotable = class(TAbstractSimpleRemotable)
|
|
private
|
|
FBinaryData : TByteDynArray;
|
|
private
|
|
function GetEncodedString : string; virtual; abstract;
|
|
procedure SetEncodedString(const AValue : string); virtual; abstract;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
procedure LoadFromStream(AStream : TStream);
|
|
procedure LoadFromFile(const AFileName : string);
|
|
procedure LoadFromBuffer(const ABuffer; const ABufferLen : Integer);
|
|
procedure SaveToStream(AStream : TStream);
|
|
procedure SaveToFile(const AFileName : string);
|
|
function SaveToBuffer(var ABuffer; const ABufferLen : Integer) : Integer;
|
|
property BinaryData : TByteDynArray read FBinaryData write FBinaryData;
|
|
property EncodedString : string read GetEncodedString write SetEncodedString;
|
|
end;
|
|
|
|
{ TBase64StringRemotable }
|
|
|
|
TBase64StringRemotable = class(TAbstractEncodedStringRemotable)
|
|
private
|
|
function GetEncodedString : string; override;
|
|
procedure SetEncodedString(const AValue : string); override;
|
|
end;
|
|
|
|
{ TBase16StringRemotable }
|
|
|
|
TBase16StringRemotable = class(TAbstractEncodedStringRemotable)
|
|
private
|
|
function GetEncodedString : string; override;
|
|
procedure SetEncodedString(const AValue : string); override;
|
|
end;
|
|
|
|
{ TBaseDateRemotable }
|
|
|
|
TBaseDateRemotable = class(TAbstractSimpleRemotable)
|
|
private
|
|
FDate : TDateTimeRec;
|
|
private
|
|
function GetAsString: string;
|
|
function GetOffset(const Index: Integer): Shortint;
|
|
procedure SetAsString(const AValue: string);
|
|
procedure SetOffset(const Index: Integer; const Value: Shortint);
|
|
function GetDate(const AIndex : Integer) : TDateTime;
|
|
protected
|
|
function GetDatepart(const AIndex : Integer) : Integer;virtual;
|
|
procedure SetDate(const AIndex : Integer; const AValue: TDateTime);virtual;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class function ToStr(const ADate : TDateTime):string;overload;
|
|
class function ToStr(const ADate : TDateTimeRec):string;overload;virtual;abstract;
|
|
class function Parse(const ABuffer : string):TDateTimeRec;virtual;abstract;
|
|
class function ParseToUTC(const ABuffer : string):TDateTime;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
|
|
property AsDate : TDateTime index 0 read GetDate write SetDate;
|
|
property AsUTCDate : TDateTime index 1 read GetDate write SetDate;
|
|
property Year : Integer index 0 read GetDatepart;
|
|
property Month : Integer index 1 read GetDatepart;
|
|
property Day : Integer index 2 read GetDatepart;
|
|
property HourOffset : Shortint index 0 read GetOffset write SetOffset;
|
|
property MinuteOffset : Shortint index 1 read GetOffset write SetOffset;
|
|
property AsString : string read GetAsString write SetAsString;
|
|
end;
|
|
|
|
{ TDateRemotable }
|
|
|
|
TDateRemotable = class(TBaseDateRemotable)
|
|
public
|
|
class function ToStr(const ADate : TDateTimeRec):string;override;
|
|
class function Parse(const ABuffer : string):TDateTimeRec;override;
|
|
end;
|
|
|
|
{ TDateTimeRemotable }
|
|
|
|
TDateTimeRemotable = class(TBaseDateRemotable)
|
|
protected
|
|
function GetDatepart(const AIndex : Integer) : Integer;override;
|
|
public
|
|
class function ToStr(const ADate : TDateTimeRec):string;override;
|
|
class function Parse(const ABuffer : string):TDateTimeRec;override;
|
|
property Hour : Integer index 3 read GetDatepart;
|
|
property Minute : Integer index 4 read GetDatepart;
|
|
property Second : Integer index 5 read GetDatepart;
|
|
end;
|
|
|
|
{ TDurationRemotable }
|
|
|
|
TDurationRemotable = class(TAbstractSimpleRemotable)
|
|
private
|
|
FData : TDurationRec;
|
|
private
|
|
function GetAsString: string;
|
|
function GetNegative: Boolean;
|
|
function GetPart(AIndex: integer): PtrUInt;
|
|
procedure SetAsString(const AValue: string);
|
|
procedure SetNegative(const AValue: Boolean);
|
|
procedure SetPart(AIndex: integer; const AValue: PtrUInt);
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
procedure Clear();
|
|
|
|
class function Parse(const ABuffer : string) : TDurationRec;
|
|
class function ToStr(const AValue : TDurationRec):string;
|
|
|
|
property Negative : Boolean read GetNegative write SetNegative;
|
|
property Year : PtrUInt index 0 read GetPart write SetPart;
|
|
property Month : PtrUInt index 1 read GetPart write SetPart;
|
|
property Day : PtrUInt index 2 read GetPart write SetPart;
|
|
property Hour : PtrUInt index 3 read GetPart write SetPart;
|
|
property Minute : PtrUInt index 4 read GetPart write SetPart;
|
|
property Second : PtrUInt index 5 read GetPart write SetPart;
|
|
property FractionalSecond : PtrUInt index 6 read GetPart write SetPart;
|
|
property AsString : string read GetAsString write SetAsString;
|
|
end;
|
|
|
|
{ TTimeRemotable }
|
|
|
|
TTimeRemotable = class(TAbstractSimpleRemotable)
|
|
private
|
|
FData : TTimeRec;
|
|
private
|
|
function GetOffset(AIndex: integer): Shortint;
|
|
function GetPart(AIndex: integer): Byte;
|
|
procedure SetMilliSecond(const AValue: Word);
|
|
procedure SetOffset(AIndex: integer; const AValue: Shortint);
|
|
procedure SetPart(AIndex: integer; const AValue: Byte);
|
|
function GetAsString: string;
|
|
function GetMilliSecond: Word;
|
|
procedure SetAsString(const AValue: string);
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
procedure Clear();
|
|
|
|
class function Parse(const ABuffer : string) : TTimeRec;
|
|
class function ToStr(const AValue : TTimeRec) : string;
|
|
|
|
property Hour : Byte index 0 read GetPart write SetPart;
|
|
property Minute : Byte index 1 read GetPart write SetPart;
|
|
property Second : Byte index 2 read GetPart write SetPart;
|
|
property MilliSecond : Word read GetMilliSecond write SetMilliSecond;
|
|
property HourOffset : Shortint index 0 read GetOffset write SetOffset;
|
|
property MinuteOffset : Shortint index 1 read GetOffset write SetOffset;
|
|
|
|
property Data : TTimeRec read FData write FData;
|
|
property AsString : string read GetAsString write SetAsString;
|
|
end;
|
|
|
|
TAbstractComplexRemotableClass = class of TAbstractComplexRemotable;
|
|
|
|
{ TAbstractComplexRemotable }
|
|
|
|
TAbstractComplexRemotable = class(TBaseRemotable)
|
|
public
|
|
class procedure RegisterAttributeProperty(const AProperty : shortstring);virtual;
|
|
class procedure RegisterAttributeProperties(const APropertList : array of shortstring);virtual;
|
|
class function IsAttributeProperty(const AProperty : shortstring):Boolean;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
end;
|
|
|
|
TBaseComplexRemotableClass = class of TBaseComplexRemotable;
|
|
|
|
{ TBaseComplexRemotable }
|
|
|
|
TBaseComplexRemotable = class(TAbstractComplexRemotable)
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
end;
|
|
|
|
TRemotableRecordEncoderClass = class of TRemotableRecordEncoder;
|
|
|
|
{ TRemotableRecordEncoder }
|
|
|
|
TRemotableRecordEncoder = class(TPersistent)
|
|
public
|
|
class procedure Save(
|
|
ARecord : Pointer;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);virtual;
|
|
class procedure Load(
|
|
var ARecord : Pointer;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);virtual;
|
|
end;
|
|
|
|
{ TBaseComplexSimpleContentRemotable }
|
|
|
|
TBaseComplexSimpleContentRemotable = class(TAbstractComplexRemotable)
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);virtual;abstract;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);virtual;abstract;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
end;
|
|
TBaseComplexSimpleContentRemotableClass = class of TBaseComplexSimpleContentRemotable;
|
|
|
|
{ TComplexEnumContentRemotable }
|
|
|
|
TComplexEnumContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
class function GetEnumTypeInfo() : PTypeInfo;virtual;abstract;
|
|
function GetValueAddress() : Pointer;virtual;abstract;
|
|
end;
|
|
|
|
{ TComplexInt8UContentRemotable }
|
|
|
|
TComplexInt8UContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Byte;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Byte read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt8SContentRemotable }
|
|
|
|
TComplexInt8SContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: ShortInt;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : ShortInt read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt16SContentRemotable }
|
|
|
|
TComplexInt16SContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: SmallInt;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : SmallInt read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt16UContentRemotable }
|
|
|
|
TComplexInt16UContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Word;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Word read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt32SContentRemotable }
|
|
|
|
TComplexInt32SContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: LongInt;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : LongInt read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt32UContentRemotable }
|
|
|
|
TComplexInt32UContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: LongWord;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : LongWord read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt64SContentRemotable }
|
|
|
|
TComplexInt64SContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Int64;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Int64 read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexInt64UContentRemotable }
|
|
|
|
TComplexInt64UContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: QWord;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : QWord read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexFloatExtendedContentRemotable }
|
|
|
|
TComplexFloatExtendedContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Extended;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Extended read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexFloatDoubleContentRemotable }
|
|
|
|
TComplexFloatDoubleContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Double;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Double read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexFloatSingleContentRemotable }
|
|
|
|
TComplexFloatSingleContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Single;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Single read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexCurrencyContentRemotable }
|
|
|
|
TComplexCurrencyContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Currency;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Currency read FValue write FValue;
|
|
end;
|
|
|
|
TComplexAnsiCharContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: AnsiChar;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
property Value : AnsiChar read FValue write FValue;
|
|
end;
|
|
|
|
TComplexWideCharContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: WideChar;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
property Value : WideChar read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexStringContentRemotable }
|
|
|
|
TComplexStringContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: string;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : string read FValue write FValue;
|
|
end;
|
|
|
|
{ TComplexWideStringContentRemotable }
|
|
|
|
TComplexWideStringContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Widestring;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : Widestring read FValue write FValue;
|
|
end;
|
|
|
|
{$IFDEF WST_UNICODESTRING}
|
|
{ TComplexUnicodeStringContentRemotable }
|
|
|
|
TComplexUnicodeStringContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: UnicodeString;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
function wstHasValue() : Boolean;override;
|
|
property Value : UnicodeString read FValue write FValue;
|
|
end;
|
|
{$ENDIF WST_UNICODESTRING}
|
|
|
|
{ TAbstractEncodedStringExtRemotable }
|
|
|
|
TAbstractEncodedStringExtRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FBinaryData : TByteDynArray;
|
|
private
|
|
function GetEncodedString : string; virtual; abstract;
|
|
procedure SetEncodedString(const AValue : string); virtual; abstract;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
function wstHasValue() : Boolean;override;
|
|
procedure LoadFromStream(AStream : TStream);
|
|
procedure LoadFromFile(const AFileName : string);
|
|
procedure LoadFromBuffer(const ABuffer; const ABufferLen : Integer);
|
|
procedure SaveToStream(AStream : TStream);
|
|
procedure SaveToFile(const AFileName : string);
|
|
function SaveToBuffer(var ABuffer; const ABufferLen : Integer) : Integer;
|
|
property BinaryData : TByteDynArray read FBinaryData write FBinaryData;
|
|
property EncodedString : string read GetEncodedString write SetEncodedString;
|
|
end;
|
|
|
|
{ TBase64StringExtRemotable }
|
|
|
|
TBase64StringExtRemotable = class(TAbstractEncodedStringExtRemotable)
|
|
private
|
|
function GetEncodedString : string; override;
|
|
procedure SetEncodedString(const AValue : string); override;
|
|
end;
|
|
|
|
{ TBase16StringExtRemotable }
|
|
|
|
TBase16StringExtRemotable = class(TAbstractEncodedStringExtRemotable)
|
|
private
|
|
function GetEncodedString : string; override;
|
|
procedure SetEncodedString(const AValue : string); override;
|
|
end;
|
|
|
|
{ TComplexBooleanContentRemotable }
|
|
|
|
TComplexBooleanContentRemotable = class(TBaseComplexSimpleContentRemotable)
|
|
private
|
|
FValue: Boolean;
|
|
protected
|
|
class procedure SaveValue(AObject : TBaseRemotable; AStore : IFormatterBase);override;
|
|
class procedure LoadValue(var AObject : TObject; AStore : IFormatterBase);override;
|
|
public
|
|
property Value : Boolean read FValue write FValue;
|
|
end;
|
|
|
|
THeaderBlockClass = class of THeaderBlock;
|
|
|
|
{ THeaderBlock }
|
|
|
|
THeaderBlock = class(TBaseComplexRemotable)
|
|
private
|
|
FDirection: THeaderDirection;
|
|
FmustUnderstand: Integer;
|
|
FName: string;
|
|
FUnderstood: Boolean;
|
|
private
|
|
function HasmustUnderstand: boolean;
|
|
procedure SetmustUnderstand(const AValue: Integer);
|
|
protected
|
|
function GetName: string; virtual;
|
|
procedure SetName(const AValue: string); virtual;
|
|
public
|
|
property Direction : THeaderDirection read FDirection write FDirection;
|
|
property Understood : Boolean read FUnderstood write FUnderstood;
|
|
property Name : string read GetName write SetName;
|
|
published
|
|
property mustUnderstand : Integer read FmustUnderstand write SetmustUnderstand stored HasmustUnderstand;
|
|
end;
|
|
|
|
{ TSimpleContentHeaderBlock
|
|
Make a derived class of TSimpleContentHeaderBlock to handle a simple content
|
|
header block.
|
|
}
|
|
TSimpleContentHeaderBlock = class(THeaderBlock)
|
|
private
|
|
FValue : string;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
property Value : string read FValue write FValue;
|
|
end;
|
|
|
|
{ THeaderBlockProxy
|
|
This class is used as a wrapper to allow a TBaseRemotable instance to be
|
|
sent and received as a header block.
|
|
}
|
|
THeaderBlockProxy = class(THeaderBlock)
|
|
private
|
|
FActualObject: TBaseRemotable;
|
|
FOwnObject: Boolean;
|
|
FNameSet : Boolean;
|
|
private
|
|
procedure SetActualObject(const AValue: TBaseRemotable);
|
|
protected
|
|
function GetName : string; override;
|
|
procedure SetName(const AValue: string); override;
|
|
public
|
|
procedure FreeObjectProperties();override;
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
property ActualObject : TBaseRemotable read FActualObject write SetActualObject;
|
|
property OwnObject : Boolean read FOwnObject write FOwnObject;
|
|
end;
|
|
|
|
{ TBaseArrayRemotable }
|
|
|
|
TBaseArrayRemotable = class(TAbstractComplexRemotable)
|
|
private
|
|
FOptions : TInstanceOptions;
|
|
protected
|
|
class function GetItemName():string;virtual;
|
|
class function GetStyle():TArrayStyle;virtual;
|
|
procedure CheckIndex(const AIndex : Integer);
|
|
function GetLength():Integer;virtual;abstract;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;virtual;abstract;
|
|
destructor Destroy();override;
|
|
|
|
procedure SetLength(const ANewSize : Integer);virtual;abstract;
|
|
property Length : Integer Read GetLength;
|
|
property Options : TInstanceOptions read FOptions write FOptions;
|
|
end;
|
|
|
|
TBaseArrayRemotableClass = class of TBaseArrayRemotable;
|
|
|
|
{ TBaseObjectArrayRemotable
|
|
An implementation for array handling. The array items are "owned" by
|
|
this class instance, so one has not to free them.
|
|
}
|
|
TBaseObjectArrayRemotable = class(TBaseArrayRemotable)
|
|
Private
|
|
FArray : Array Of TBaseRemotable;
|
|
Protected
|
|
function GetItem(AIndex: Integer): TBaseRemotable;
|
|
function GetLength():Integer;override;
|
|
Public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
Const AName : String;
|
|
Const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
Var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
|
|
class function GetItemClass():TBaseRemotableClass;virtual;abstract;
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
|
|
constructor Create();override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
procedure Exchange(const Index1,Index2 : Integer);
|
|
|
|
procedure SetLength(Const ANewSize : Integer);override;
|
|
Property Item[AIndex:Integer] : TBaseRemotable Read GetItem;Default;
|
|
End;
|
|
|
|
TBaseObjectArrayRemotableClass = class of TBaseObjectArrayRemotable;
|
|
|
|
{ TObjectCollectionRemotable
|
|
An implementation for array handling. The array items are "owned" by
|
|
this class instance, so one has not to free them.
|
|
}
|
|
TObjectCollectionRemotable = class(TBaseArrayRemotable)
|
|
private
|
|
FList : TObjectList;
|
|
protected
|
|
function GetItem(AIndex : Integer) : TBaseRemotable;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function GetLength() : Integer; override;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class function GetItemClass():TBaseRemotableClass;virtual;abstract;
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
|
|
constructor Create();override;
|
|
destructor Destroy();override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
|
|
function Add(): TBaseRemotable;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function AddAt(const APosition : Integer): TBaseRemotable;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function Extract(const AIndex : Integer): TBaseRemotable;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure Delete(const AIndex : Integer);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure Exchange(const Index1,Index2 : Integer);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure Clear();{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function IndexOf(AObject : TBaseRemotable) : Integer;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
|
|
procedure SetLength(Const ANewSize : Integer);override;
|
|
property Item[AIndex:Integer] : TBaseRemotable read GetItem;default;
|
|
end;
|
|
|
|
{ TBaseSimpleTypeArrayRemotable }
|
|
|
|
TBaseSimpleTypeArrayRemotable = class(TBaseArrayRemotable)
|
|
protected
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);virtual;abstract;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);virtual;abstract;
|
|
public
|
|
class procedure Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
class procedure Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);override;
|
|
end;
|
|
|
|
{ TArrayOfStringRemotable }
|
|
// --------- Compiler Native String type !!!! ----------
|
|
TArrayOfStringRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of String;
|
|
function GetItem(AIndex: Integer): String;
|
|
procedure SetItem(AIndex: Integer; const AValue: String);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
function Equal(const ACompareTo : TBaseRemotable) : Boolean;override;
|
|
property Item[AIndex:Integer] : String read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfBooleanRemotable }
|
|
|
|
TArrayOfBooleanRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Boolean;
|
|
function GetItem(AIndex: Integer): Boolean;
|
|
procedure SetItem(AIndex: Integer; const AValue: Boolean);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Boolean read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt8URemotable }
|
|
|
|
TArrayOfInt8URemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Byte;
|
|
function GetItem(AIndex: Integer): Byte;
|
|
procedure SetItem(AIndex: Integer; const AValue: Byte);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Byte read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt8SRemotable }
|
|
|
|
TArrayOfInt8SRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of ShortInt;
|
|
function GetItem(AIndex: Integer): ShortInt;
|
|
procedure SetItem(AIndex: Integer; const AValue: ShortInt);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : ShortInt read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt16SRemotable }
|
|
|
|
TArrayOfInt16SRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of SmallInt;
|
|
function GetItem(AIndex: Integer): SmallInt;
|
|
procedure SetItem(AIndex: Integer; const AValue: SmallInt);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : SmallInt read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt16URemotable }
|
|
|
|
TArrayOfInt16URemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Word;
|
|
function GetItem(AIndex: Integer): Word;
|
|
procedure SetItem(AIndex: Integer; const AValue: Word);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Word read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt32URemotable }
|
|
|
|
TArrayOfInt32URemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of LongWord;
|
|
function GetItem(AIndex: Integer): LongWord;
|
|
procedure SetItem(AIndex: Integer; const AValue: LongWord);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : LongWord read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt32SRemotable }
|
|
|
|
TArrayOfInt32SRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of LongInt;
|
|
function GetItem(AIndex: Integer): LongInt;
|
|
procedure SetItem(AIndex: Integer; const AValue: LongInt);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : LongInt read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt64SRemotable }
|
|
|
|
TArrayOfInt64SRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Int64;
|
|
function GetItem(AIndex: Integer): Int64;
|
|
procedure SetItem(AIndex: Integer; const AValue: Int64);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Int64 read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfInt64URemotable }
|
|
|
|
TArrayOfInt64URemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of QWord;
|
|
function GetItem(AIndex: Integer): QWord;
|
|
procedure SetItem(AIndex: Integer; const AValue: QWord);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : QWord read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfFloatSingleRemotable }
|
|
|
|
TArrayOfFloatSingleRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Single;
|
|
function GetItem(AIndex: Integer): Single;
|
|
procedure SetItem(AIndex: Integer; const AValue: Single);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Single read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfFloatDoubleRemotable }
|
|
|
|
TArrayOfFloatDoubleRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Double;
|
|
function GetItem(AIndex: Integer): Double;
|
|
procedure SetItem(AIndex: Integer; const AValue: Double);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Double read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfFloatExtendedRemotable }
|
|
|
|
TArrayOfFloatExtendedRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Extended;
|
|
function GetItem(AIndex: Integer): Extended;
|
|
procedure SetItem(AIndex: Integer; const AValue: Extended);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Extended read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TArrayOfFloatCurrencyRemotable }
|
|
|
|
TArrayOfFloatCurrencyRemotable = class(TBaseSimpleTypeArrayRemotable)
|
|
private
|
|
FData : array of Currency;
|
|
function GetItem(AIndex: Integer): Currency;
|
|
procedure SetItem(AIndex: Integer; const AValue: Currency);
|
|
protected
|
|
function GetLength():Integer;override;
|
|
procedure SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);override;
|
|
procedure LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);override;
|
|
public
|
|
class function GetItemTypeInfo():PTypeInfo;override;
|
|
procedure SetLength(const ANewSize : Integer);override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
property Item[AIndex:Integer] : Currency read GetItem write SetItem; default;
|
|
end;
|
|
|
|
{ TBaseFactoryRegistryItem }
|
|
// Implementation helpers
|
|
TBaseFactoryRegistryItem = class
|
|
private
|
|
FFactory: IItemFactory;
|
|
FName: string;
|
|
public
|
|
constructor Create(
|
|
const AName : string;
|
|
const AFactory : IItemFactory
|
|
);
|
|
destructor Destroy();override;
|
|
property Name : string Read FName;
|
|
property Factory : IItemFactory Read FFactory;
|
|
End;
|
|
|
|
{ TBaseFactoryRegistry }
|
|
TBaseFactoryRegistry = class(TInterfacedObject,IInterface)
|
|
private
|
|
FList : TObjectList;
|
|
function GetCount: Integer;
|
|
function GetItem(Index: Integer): TBaseFactoryRegistryItem;
|
|
protected
|
|
function FindFactory(const AName: string): IItemFactory;
|
|
procedure Register(
|
|
const AName : string;
|
|
AFactory : IItemFactory
|
|
);
|
|
protected
|
|
property Count : Integer read GetCount;
|
|
property Item[Index:Integer] : TBaseFactoryRegistryItem read GetItem;
|
|
public
|
|
constructor Create();
|
|
destructor Destroy();override;
|
|
End;
|
|
|
|
{ TSimpleFactoryItem }
|
|
|
|
TSimpleFactoryItem = class(TInterfacedObject)
|
|
public
|
|
constructor Create();virtual;
|
|
End;
|
|
|
|
TSimpleFactoryItemClass = class of TSimpleFactoryItem;
|
|
|
|
{ TSimpleItemFactory }
|
|
{$TYPEINFO ON}
|
|
TSimpleItemFactory = class(TInterfacedObject,IItemFactory)
|
|
private
|
|
FItemClass : TSimpleFactoryItemClass;
|
|
protected
|
|
function CreateInstance():IInterface;virtual;
|
|
function GetItemClass() : TSimpleFactoryItemClass;
|
|
public
|
|
constructor Create(AItemClass : TSimpleFactoryItemClass);
|
|
End;
|
|
{$TYPEINFO OFF}
|
|
{ TIntfPoolItem }
|
|
|
|
TIntfPoolItem = class
|
|
private
|
|
FIntf: IInterface;
|
|
FUsed: Boolean;
|
|
public
|
|
constructor Create(AIntf : IInterface; const AUsed : Boolean);
|
|
destructor Destroy();override;
|
|
property Intf : IInterface read FIntf;
|
|
property Used : Boolean read FUsed write FUsed;
|
|
end;
|
|
|
|
TIntfPool = class
|
|
private
|
|
FList : TObjectList;
|
|
FCS : TCriticalSection;
|
|
FLock : TSemaphoreObject;
|
|
FFactory : IItemFactory;
|
|
FMin : Integer;
|
|
FMax : Integer;
|
|
private
|
|
function CreateNew(const AUsed : Boolean) : TIntfPoolItem;
|
|
function TryGet(const AIndex: Integer): Boolean;
|
|
public
|
|
constructor Create(
|
|
const AMin, AMax : Integer;
|
|
AFactory : IItemFactory
|
|
);
|
|
destructor Destroy();override;
|
|
function Get(const ATimeOut : Cardinal) : IInterface;
|
|
procedure Release(const AItem : IInterface);
|
|
procedure Discard(const AItem : IInterface);
|
|
function GetInstancesCount: Integer;
|
|
property Min : Integer read FMin;
|
|
property Max : Integer read FMax;
|
|
end;
|
|
|
|
{ TSimpleItemFactoryEx }
|
|
|
|
TSimpleItemFactoryEx = class(TSimpleItemFactory,IItemFactory,IItemFactoryEx)
|
|
private
|
|
FPooled: Boolean;
|
|
FPoolMax: Integer;
|
|
FPoolMin: Integer;
|
|
FPropertyNames : TStringList;
|
|
FProperties : IInterfaceList;
|
|
FPool : TIntfPool;
|
|
FTimeOut: PtrUInt;
|
|
private
|
|
procedure PreparePool();{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure SetPooled(const AValue: Boolean);
|
|
procedure SetPoolMax(const AValue: Integer);
|
|
procedure SetPoolMin(const AValue: Integer);
|
|
protected
|
|
function CreateInstance():IInterface;override;
|
|
procedure ReleaseInstance(const AInstance : IInterface);virtual;
|
|
procedure DiscardInstance(const AInstance : IInterface);virtual;
|
|
function GetPropertyManager(
|
|
const APropertyGroup : string;
|
|
const ACreateIfNotExists : Boolean
|
|
):IPropertyManager;
|
|
public
|
|
constructor Create(
|
|
AItemClass : TSimpleFactoryItemClass;
|
|
const APropsString : string
|
|
);overload;
|
|
constructor Create(AItemClass : TSimpleFactoryItemClass);overload;
|
|
destructor Destroy();override;
|
|
published
|
|
property PoolMax : Integer read FPoolMax write SetPoolMax;
|
|
property PoolMin : Integer read FPoolMin write SetPoolMin;
|
|
property Pooled : Boolean read FPooled write SetPooled;
|
|
property TimeOut : PtrUInt read FTimeOut write FTimeOut;
|
|
end;
|
|
|
|
TTypeRegistryItemOption = (
|
|
trioNonVisibleToMetadataService,
|
|
trioUnqualifiedElement, trioQualifiedElement,
|
|
trioUnqualifiedAttribute, trioQualifiedAttribute
|
|
);
|
|
TTypeRegistryItemOptions = set of TTypeRegistryItemOption;
|
|
TTypeRegistry = class;
|
|
TTypeRegistryItem = class;
|
|
TTypeRegistryItemClass = class of TTypeRegistryItem;
|
|
|
|
TRemotableTypeInitializerClass = class of TRemotableTypeInitializer;
|
|
|
|
{ TRemotableTypeInitializer }
|
|
|
|
TRemotableTypeInitializer = class
|
|
public
|
|
class function CanHandle(ATypeInfo : PTypeInfo) : Boolean;virtual;
|
|
class function GetItemClass(const ATypeInfo : PTypeInfo) : TTypeRegistryItemClass;virtual;
|
|
{$IFDEF TRemotableTypeInitializer_Initialize}
|
|
class function Initialize(
|
|
ATypeInfo : PTypeInfo;
|
|
ARegistryItem : TTypeRegistryItem
|
|
) : Boolean;virtual;abstract;
|
|
{$ENDIF TRemotableTypeInitializer_Initialize}
|
|
end;
|
|
|
|
TPropertyNameType = ( pntInternalName, pntExternalName );
|
|
|
|
{ TPropertyItem }
|
|
|
|
TPropertyItem = class
|
|
private
|
|
FExternalName: string;
|
|
FExtObject: TObject;
|
|
FInternalName: string;
|
|
FOptions: TTypeRegistryItemOptions;
|
|
public
|
|
property InternalName : string read FInternalName {write FInternalName};
|
|
property ExternalName : string read FExternalName {write FExternalName};
|
|
property ExtObject : TObject read FExtObject {write FExtObject};
|
|
property Options : TTypeRegistryItemOptions read FOptions {write FOptions};
|
|
end;
|
|
|
|
{ TTypeRegistryItem }
|
|
|
|
TTypeRegistryItem = class
|
|
private
|
|
//FDefaultPropertyOptions: TTypeRegistryItemOptions;
|
|
FOwner : TTypeRegistry;
|
|
FDataType: PTypeInfo;
|
|
FNameSpace: string;
|
|
FDeclaredName : string;
|
|
FOptions: TTypeRegistryItemOptions;
|
|
FPascalSynonyms : TStrings;
|
|
FExternalSynonyms : TStrings;
|
|
FProperties : TObjectList;
|
|
procedure SetOptions(AValue: TTypeRegistryItemOptions);
|
|
protected
|
|
procedure Init(); virtual;
|
|
protected
|
|
function IndexOfProp(
|
|
const AName : string;
|
|
const ANameType : TPropertyNameType
|
|
) : Integer;
|
|
public
|
|
constructor Create(
|
|
AOwner : TTypeRegistry;
|
|
ANameSpace : string;
|
|
ADataType : PTypeInfo;
|
|
Const ADeclaredName : string = ''
|
|
);virtual;
|
|
destructor Destroy();override;
|
|
function AddPascalSynonym(const ASynonym : string):TTypeRegistryItem;
|
|
function AddExternalSynonym(const ASynonym : string):TTypeRegistryItem;
|
|
function IsSynonym(const APascalTypeName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function IsExternalSynonym(const AExternalName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
|
|
function FindProperty(
|
|
const AName : string;
|
|
const ANameType : TPropertyNameType
|
|
) : TPropertyItem;
|
|
procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); virtual;
|
|
function GetExternalPropertyName(const APropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function GetInternalPropertyName(const AExtPropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure SetPropertyOptions(
|
|
const APropName : string;
|
|
const AOptions : TTypeRegistryItemOptions
|
|
); virtual;
|
|
procedure AddOptions(const AOptions : TTypeRegistryItemOptions);
|
|
|
|
procedure RegisterObject(const APropName : string; const AObject : TObject);
|
|
function GetObject(const APropName : string) : TObject;
|
|
|
|
property Owner : TTypeRegistry read FOwner;
|
|
property DataType : PTypeInfo read FDataType;
|
|
property NameSpace : string read FNameSpace;
|
|
property DeclaredName : string read FDeclaredName;
|
|
property Options : TTypeRegistryItemOptions read FOptions write SetOptions;
|
|
//property DefaultPropertyOptions : TTypeRegistryItemOptions
|
|
//read FDefaultPropertyOptions write FDefaultPropertyOptions;
|
|
end;
|
|
|
|
TTypeRegistrySearchOption = ( trsoIncludeExternalSynonyms );
|
|
TTypeRegistrySearchOptions = set of TTypeRegistrySearchOption;
|
|
|
|
{ TTypeRegistry }
|
|
|
|
TTypeRegistry = class
|
|
private
|
|
FList : TObjectList;
|
|
FInitializerList : TClassList;
|
|
private
|
|
function GetItemClassFor(const ATypeInfo : PTypeInfo) : TTypeRegistryItemClass;
|
|
{$IFDEF TRemotableTypeInitializer_Initialize}
|
|
procedure InitializeItem(AItem : TTypeRegistryItem);
|
|
{$ENDIF TRemotableTypeInitializer_Initialize}
|
|
function GetCount: Integer;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function GetItemByIndex(Index: Integer): TTypeRegistryItem;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
function GetItemByTypeInfo(Index: PTypeInfo): TTypeRegistryItem;
|
|
public
|
|
constructor Create();
|
|
destructor Destroy();override;
|
|
procedure RegisterInitializer(AInitializer : TRemotableTypeInitializerClass);
|
|
function IndexOf(Const ATypeInfo : PTypeInfo):Integer;
|
|
function Add(AItem:TTypeRegistryItem):Integer;
|
|
function Register(
|
|
const ANameSpace : string;
|
|
const ADataType : PTypeInfo;
|
|
const ADeclaredName : string;
|
|
const AOptions : TTypeRegistryItemOptions
|
|
):TTypeRegistryItem;overload;
|
|
function Register(
|
|
Const ANameSpace : String;
|
|
Const ADataType : PTypeInfo;
|
|
Const ADeclaredName : String = ''
|
|
):TTypeRegistryItem;overload;
|
|
function Find(ATypeInfo : PTypeInfo; Const AExact : Boolean):TTypeRegistryItem;overload;
|
|
function Find(const APascalTypeName : string):TTypeRegistryItem;overload;
|
|
function FindByDeclaredName(
|
|
const ATypeName,
|
|
ANameSpace : string;
|
|
const AOptions : TTypeRegistrySearchOptions = []
|
|
) : TTypeRegistryItem;
|
|
Property Count : Integer Read GetCount;
|
|
Property Item[Index:Integer] : TTypeRegistryItem Read GetItemByIndex;default;
|
|
Property ItemByTypeInfo[Index:PTypeInfo] : TTypeRegistryItem Read GetItemByTypeInfo;
|
|
end;
|
|
|
|
TPropStoreType = ( pstNever, pstOptional, pstAlways );
|
|
|
|
EPropertyException = class(Exception)
|
|
end;
|
|
|
|
{ TStoredPropertyManager }
|
|
|
|
TStoredPropertyManager = class(TInterfacedObject,IPropertyManager)
|
|
private
|
|
FData : TStringList;
|
|
procedure Error(Const AMsg:string);overload;
|
|
procedure Error(Const AMsg:string; Const AArgs : array of const);overload;
|
|
protected
|
|
procedure SetProperty(Const AName,AValue:string);
|
|
procedure SetProperties(Const APropsStr:string);
|
|
function GetProperty(Const AName:String):string;
|
|
function GetPropertyNames(ADest : TStrings):Integer;
|
|
procedure Clear();
|
|
procedure Copy(ASource:IPropertyManager; Const AClearBefore : Boolean);
|
|
public
|
|
constructor Create();
|
|
destructor Destroy();override;
|
|
end;
|
|
|
|
const
|
|
sXSD_NS = 'http://www.w3.org/2001/XMLSchema';
|
|
sXSD = 'xsd';
|
|
sSOAP_ENV = 'http://schemas.xmlsoap.org/soap/envelope/';
|
|
sSOAP_ENV_ABR = 'SOAP-ENV';
|
|
sWST_BASE_NS_ABR = 'wst';
|
|
sWST_BASE_NS = 'urn:wst_base';
|
|
|
|
PROP_LIST_DELIMITER = ';';
|
|
FIELDS_STRING = '__FIELDS__';
|
|
|
|
function GetTypeRegistry():TTypeRegistry;
|
|
procedure RegisterStdTypes();overload;{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
procedure RegisterStdTypes(ARegistry : TTypeRegistry);overload;
|
|
procedure RegisterAttributeProperty(
|
|
const ATypeInfo : PTypeInfo; // must be tkClass or tkRecord
|
|
const AProperty : shortstring
|
|
);
|
|
procedure SetFieldSerializationVisibility(
|
|
const ATypeInfo : PTypeInfo; // must be tkRecord
|
|
const AField : shortstring;
|
|
const AVisibility : Boolean
|
|
);
|
|
function GetExternalName(
|
|
const ATypeInfo : PTypeInfo;
|
|
const ARegistry : TTypeRegistry = nil
|
|
) : string;
|
|
|
|
|
|
function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType;
|
|
|
|
procedure initialize_base_service_intf();
|
|
procedure finalize_base_service_intf();
|
|
|
|
{$IFDEF HAS_FORMAT_SETTINGS}
|
|
var
|
|
wst_FormatSettings : TFormatSettings;
|
|
{$ENDIF HAS_FORMAT_SETTINGS}
|
|
|
|
implementation
|
|
uses
|
|
wst_consts, imp_utils, record_rtti, basex_encode, object_serializer, DateUtils;
|
|
|
|
|
|
type
|
|
PObject = ^TObject;
|
|
|
|
TEnumBuffer = Record
|
|
Case TOrdType Of
|
|
otSByte : (ShortIntData : ShortInt);
|
|
otUByte : (ByteData : Byte);
|
|
otSWord : (SmallIntData : SmallInt);
|
|
otUWord : (WordData : Word);
|
|
otSLong : (SLongIntData : LongInt);
|
|
otULong : (ULongIntData : LongWord);
|
|
End;
|
|
TFloatBuffer = Record
|
|
Case TFloatType Of
|
|
ftSingle : (SingleData : Single);
|
|
ftDouble : (DoubleData : Double);
|
|
ftExtended : (ExtendedData : Extended);
|
|
ftCurr : (CurrencyData : Currency);
|
|
ftComp : (CompData : Comp);
|
|
End;
|
|
|
|
var
|
|
TypeRegistryInstance : TTypeRegistry = Nil;
|
|
|
|
function GetTypeRegistry():TTypeRegistry;
|
|
begin
|
|
If Not Assigned(TypeRegistryInstance) Then
|
|
TypeRegistryInstance := TTypeRegistry.Create();
|
|
Result := TypeRegistryInstance;
|
|
end;
|
|
|
|
procedure RegisterStdTypes();
|
|
begin
|
|
RegisterStdTypes(GetTypeRegistry());
|
|
end;
|
|
|
|
procedure RegisterStdTypes(ARegistry : TTypeRegistry);
|
|
Var
|
|
r : TTypeRegistry;
|
|
ri : TTypeRegistryItem;
|
|
begin
|
|
r := ARegistry;
|
|
r.Register(sXSD_NS,TypeInfo(Integer),'int').AddPascalSynonym('Integer');
|
|
r.Register(sXSD_NS,TypeInfo(LongWord),'unsignedInt');
|
|
r.Register(sXSD_NS,TypeInfo(positiveInteger),'positiveInteger');
|
|
r.Register(sXSD_NS,TypeInfo(nonNegativeInteger),'nonNegativeInteger');
|
|
|
|
|
|
r.Register(sXSD_NS,TypeInfo(string),'string').AddPascalSynonym('string');
|
|
r.Register(sXSD_NS,TypeInfo(AnsiString),'ansistring').AddPascalSynonym('ansistring');
|
|
r.Register(sXSD_NS,TypeInfo(WideString),'widestring').AddPascalSynonym('widestring');
|
|
{$IFDEF WST_UNICODESTRING}
|
|
r.Register(sXSD_NS,TypeInfo(UnicodeString),'UnicodeString').AddPascalSynonym('unicodestring');
|
|
{$ENDIF WST_UNICODESTRING}
|
|
r.Register(sXSD_NS,TypeInfo(anyURI),'anyURI').AddPascalSynonym('anyURI');
|
|
r.Register(sXSD_NS,TypeInfo(anyType_Type),'anyType').AddPascalSynonym('anyType_Type');
|
|
r.Register(sXSD_NS,TypeInfo(schema_Type),'schema').AddPascalSynonym('schema_Type');
|
|
r.Register(sXSD_NS,TypeInfo(token),'token').AddPascalSynonym('token');
|
|
r.Register(sXSD_NS,TypeInfo(language),'language').AddPascalSynonym('language');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(boolean),'boolean').AddPascalSynonym('boolean');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(Byte),'unsignedByte').AddPascalSynonym('Byte');
|
|
r.Register(sXSD_NS,TypeInfo(ShortInt),'byte').AddPascalSynonym('ShortInt');
|
|
r.Register(sXSD_NS,TypeInfo(Word),'unsignedShort').AddPascalSynonym('Word');
|
|
r.Register(sXSD_NS,TypeInfo(SmallInt),'short').AddPascalSynonym('SmallInt');
|
|
r.Register(sXSD_NS,TypeInfo(Int64),'long').AddPascalSynonym('Int64');
|
|
r.Register(sXSD_NS,TypeInfo(QWord),'unsignedLong').AddPascalSynonym('QWord');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(Single),'float').AddPascalSynonym('Single');
|
|
r.Register(sXSD_NS,TypeInfo(Currency),'float').AddPascalSynonym('Currency');
|
|
r.Register(sXSD_NS,TypeInfo(Comp),'float').AddPascalSynonym('Comp');
|
|
r.Register(sXSD_NS,TypeInfo(Double),'double').AddPascalSynonym('Double');
|
|
r.Register(sXSD_NS,TypeInfo(Extended),'decimal').AddPascalSynonym('Extended');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TDateTimeRemotable),'dateTime').AddPascalSynonym('TDateTimeRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TDateRemotable),'date').AddPascalSynonym('TDateRemotable');
|
|
{$IFDEF WST_HAS_TDURATIONREMOTABLE}
|
|
r.Register(sXSD_NS,TypeInfo(TDurationRemotable),'duration').AddPascalSynonym('TDurationRemotable');
|
|
{$ELSE WST_HAS_TDURATIONREMOTABLE}
|
|
r.Register(sXSD_NS,TypeInfo(duration),'duration').AddPascalSynonym('duration');
|
|
{$ENDIF WST_HAS_TDURATIONREMOTABLE}
|
|
{$IFDEF WST_HAS_TTIMEREMOTABLE}
|
|
r.Register(sXSD_NS,TypeInfo(TTimeRemotable),'time').AddPascalSynonym('TTimeRemotable');
|
|
{$ELSE WST_HAS_TTIMEREMOTABLE}
|
|
r.Register(sXSD_NS,TypeInfo(time),'time').AddPascalSynonym('time');
|
|
{$ENDIF WST_HAS_TTIMEREMOTABLE}
|
|
|
|
ri := r.Register(sWST_BASE_NS,TypeInfo(TBaseArrayRemotable),'TBaseArrayRemotable');
|
|
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
|
|
|
|
THeaderBlock.RegisterAttributeProperty('mustUnderstand');
|
|
ri := r.Register(sSOAP_ENV,TypeInfo(THeaderBlock),'THeaderBlock');
|
|
ri.Options := ri.Options + [trioNonVisibleToMetadataService,trioQualifiedAttribute];
|
|
ri.SetPropertyOptions('mustUnderstand',[]);
|
|
ri := r.Register(sSOAP_ENV,TypeInfo(TSimpleContentHeaderBlock));
|
|
ri.Options := ri.Options + [trioNonVisibleToMetadataService,trioQualifiedAttribute];
|
|
ri := r.Register(sSOAP_ENV,TypeInfo(THeaderBlockProxy));
|
|
ri.Options := ri.Options + [trioNonVisibleToMetadataService,trioQualifiedAttribute];
|
|
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfStringRemotable),'TArrayOfStringRemotable').AddPascalSynonym('TArrayOfStringRemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfBooleanRemotable),'TArrayOfBooleanRemotable').AddPascalSynonym('TArrayOfBooleanRemotable');
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt8URemotable),'TArrayOfInt8URemotable').AddPascalSynonym('TArrayOfInt8URemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt8SRemotable),'TArrayOfInt8SRemotable').AddPascalSynonym('TArrayOfInt8SRemotable');
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt16URemotable),'TArrayOfInt16URemotable').AddPascalSynonym('TArrayOfInt16URemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt16SRemotable),'TArrayOfInt16SRemotable').AddPascalSynonym('TArrayOfInt16SRemotable');
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt32URemotable),'TArrayOfInt32URemotable').AddPascalSynonym('TArrayOfInt32URemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt32SRemotable),'TArrayOfInt32SRemotable').AddPascalSynonym('TArrayOfInt32SRemotable');
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt64URemotable),'TArrayOfInt64URemotable').AddPascalSynonym('TArrayOfInt64URemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfInt64SRemotable),'TArrayOfInt64SRemotable').AddPascalSynonym('TArrayOfInt64SRemotable');
|
|
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfFloatSingleRemotable),'TArrayOfFloatSingleRemotable').AddPascalSynonym('TArrayOfFloatSingleRemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfFloatDoubleRemotable),'TArrayOfFloatDoubleRemotable').AddPascalSynonym('TArrayOfFloatDoubleRemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfFloatExtendedRemotable),'TArrayOfFloatExtendedRemotable').AddPascalSynonym('TArrayOfFloatExtendedRemotable');
|
|
r.Register(sWST_BASE_NS,TypeInfo(TArrayOfFloatCurrencyRemotable),'TArrayOfFloatCurrencyRemotable').AddPascalSynonym('TArrayOfFloatCurrencyRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt64SContentRemotable),'long').AddPascalSynonym('TComplexInt64SContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt64UContentRemotable),'unsignedLong').AddPascalSynonym('TComplexInt64UContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt32SContentRemotable),'int').AddPascalSynonym('TComplexInt32SContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt32UContentRemotable),'unsignedInt').AddPascalSynonym('TComplexInt32UContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt16SContentRemotable),'short').AddPascalSynonym('TComplexInt16SContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt16UContentRemotable),'unsignedShort').AddPascalSynonym('TComplexInt16UContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt8SContentRemotable),'byte').AddPascalSynonym('TComplexInt8SContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexInt8UContentRemotable),'unsignedByte').AddPascalSynonym('TComplexInt8UContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexFloatExtendedContentRemotable),'decimal').AddPascalSynonym('TComplexFloatExtendedContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexFloatDoubleContentRemotable),'double').AddPascalSynonym('TComplexFloatDoubleContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexFloatSingleContentRemotable),'Single').AddPascalSynonym('TComplexFloatSingleContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexStringContentRemotable),'string').AddPascalSynonym('TComplexStringContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexWideStringContentRemotable),'widestring').AddPascalSynonym('TComplexWideStringContentRemotable');
|
|
{$IFDEF WST_UNICODESTRING}
|
|
r.Register(sXSD_NS,TypeInfo(TComplexUnicodeStringContentRemotable),'unicodestring').AddPascalSynonym('TComplexUnicodeStringContentRemotable');
|
|
{$ENDIF WST_UNICODESTRING}
|
|
r.Register(sXSD_NS,TypeInfo(TComplexBooleanContentRemotable),'boolean').AddPascalSynonym('TComplexBooleanContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TComplexAnsiCharContentRemotable),'AnsiChar').AddPascalSynonym('TComplexAnsiCharContentRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TComplexWideCharContentRemotable),'WideChar').AddPascalSynonym('TComplexWideCharContentRemotable');
|
|
|
|
r.Register(sXSD_NS,TypeInfo(TBase64StringRemotable),'base64Binary').AddPascalSynonym('TBase64StringRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TBase64StringExtRemotable),'base64Binary').AddPascalSynonym('TBase64StringExtRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TBase16StringRemotable),'hexBinary').AddPascalSynonym('TBase16StringRemotable');
|
|
r.Register(sXSD_NS,TypeInfo(TBase16StringExtRemotable),'hexBinary').AddPascalSynonym('TBase16StringExtRemotable');
|
|
end;
|
|
|
|
function GetExternalName(
|
|
const ATypeInfo : PTypeInfo;
|
|
const ARegistry : TTypeRegistry
|
|
) : string;
|
|
var
|
|
locReg : TTypeRegistry;
|
|
locRegItem : TTypeRegistryItem;
|
|
begin
|
|
if ( ARegistry = nil ) then
|
|
locReg := GetTypeRegistry()
|
|
else
|
|
locReg := ARegistry;
|
|
locRegItem := locReg.Find(ATypeInfo,False);
|
|
if ( locRegItem <> nil ) then
|
|
Result := locRegItem.DeclaredName
|
|
else
|
|
Result := ATypeInfo^.Name;
|
|
end;
|
|
|
|
procedure SetFieldSerializationVisibility(
|
|
const ATypeInfo : PTypeInfo; // must be tkRecord
|
|
const AField : shortstring;
|
|
const AVisibility : Boolean
|
|
);
|
|
var
|
|
recordData : TRecordRttiDataObject;
|
|
begin
|
|
if Assigned(ATypeInfo) and ( ATypeInfo^.Kind = tkRecord ) and
|
|
( not IsStrEmpty(AField) )
|
|
then begin
|
|
recordData := GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetObject(FIELDS_STRING) as TRecordRttiDataObject;
|
|
if Assigned(recordData) then begin
|
|
recordData.GetField(AField)^.Visible := AVisibility;
|
|
end else begin
|
|
raise EServiceConfigException.CreateFmt(SERR_RecordExtendedRttiNotFound,[ATypeInfo^.Name]);
|
|
end;
|
|
end else begin
|
|
raise EServiceConfigException.Create(SERR_InvalidParameters);
|
|
end;
|
|
end;
|
|
|
|
procedure RegisterAttributeProperty(
|
|
const ATypeInfo : PTypeInfo;
|
|
const AProperty : shortstring
|
|
);
|
|
var
|
|
ok : Boolean;
|
|
recordData : TRecordRttiDataObject;
|
|
begin
|
|
ok := False;
|
|
if Assigned(ATypeInfo) and
|
|
( not IsStrEmpty(AProperty) )
|
|
then begin
|
|
case ATypeInfo^.Kind of
|
|
tkClass :
|
|
begin
|
|
if GetTypeData(ATypeInfo)^.ClassType.InheritsFrom(TAbstractComplexRemotable) then begin
|
|
TAbstractComplexRemotableClass(GetTypeData(ATypeInfo)^.ClassType).RegisterAttributeProperty(AProperty);
|
|
ok := True;
|
|
end;
|
|
end;
|
|
tkRecord :
|
|
begin
|
|
recordData := GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetObject(FIELDS_STRING) as TRecordRttiDataObject;
|
|
if Assigned(recordData) then begin
|
|
recordData.GetField(AProperty)^.IsAttribute := True;
|
|
ok := True;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if not ok then
|
|
raise EServiceConfigException.Create(SERR_InvalidParameters);
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType;
|
|
begin
|
|
case (PropInfo^.PropProcs shr 4) and 3 of
|
|
ptfield:
|
|
Result := pstOptional;
|
|
ptconst:
|
|
begin
|
|
if LongBool(PropInfo^.StoredProc) then
|
|
Result := pstAlways
|
|
else
|
|
Result := pstNever;
|
|
end;
|
|
ptstatic,
|
|
ptvirtual:
|
|
Result := pstOptional;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType;
|
|
{var
|
|
b : PByte;
|
|
begin
|
|
if ( ( PropInfo^.StoredProc and $0FFFFFF00 ) = 0 ) then begin
|
|
if LongBool(PropInfo^.StoredProc) then // constante
|
|
Result := pstAlways
|
|
else
|
|
Result := pstNever;
|
|
end else begin
|
|
b := PByte(PropInfo^.StoredProc);
|
|
Inc(b,3);
|
|
if ( b^ < $FE ) then begin //StaticMethod
|
|
Result := pstOptional;
|
|
end else ( b^ > $FE ) begin Field
|
|
end else begin // virtual method
|
|
end;
|
|
end;
|
|
end;}
|
|
begin
|
|
if ( ( Cardinal(PropInfo^.StoredProc) and $0FFFFFF00 ) = 0 ) then begin
|
|
if LongBool(PropInfo^.StoredProc) then begin
|
|
Result := pstAlways
|
|
end else begin
|
|
Result := pstNever;
|
|
end;
|
|
end else begin
|
|
Result := pstOptional;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ TBaseRemotable }
|
|
|
|
constructor TBaseRemotable.Create();
|
|
begin
|
|
end;
|
|
|
|
destructor TBaseRemotable.Destroy();
|
|
begin
|
|
FreeObjectProperties();
|
|
inherited Destroy();
|
|
end;
|
|
|
|
procedure TBaseRemotable.FreeObjectProperties();
|
|
begin
|
|
//Derived classes should override this method to free their object(s) and array(s).
|
|
end;
|
|
|
|
function TBaseRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
begin
|
|
Result := ( Self = ACompareTo );
|
|
end;
|
|
|
|
function TBaseRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
{ TBaseComplexRemotable }
|
|
Type
|
|
|
|
{ TSerializeOptions }
|
|
|
|
TSerializeOptions = class
|
|
private
|
|
FAttributeFieldList : TStringList;
|
|
private
|
|
FElementClass: TAbstractComplexRemotableClass;
|
|
procedure AddAttributeField(const AAttributeField : string);
|
|
function GetAttributeCount: Integer;
|
|
function GetAttributeField(AIndex : Integer): string;
|
|
public
|
|
constructor Create(const AElementClass : TAbstractComplexRemotableClass);
|
|
destructor Destroy();override;
|
|
function IsAttributeField(const AField : string):Boolean;
|
|
property ElementClass : TAbstractComplexRemotableClass read FElementClass;
|
|
property AttributeFieldCount : Integer read GetAttributeCount;
|
|
property AttributeField[AIndex : Integer] : string read GetAttributeField;
|
|
end;
|
|
|
|
{ TSerializeOptionsRegistry }
|
|
|
|
TSerializeOptionsRegistry = class
|
|
private
|
|
FList : TObjectList;
|
|
private
|
|
function GetCount: Integer;
|
|
function GetItem(AIndex : Integer): TSerializeOptions;
|
|
function IndexOf(const AElementClass : TAbstractComplexRemotableClass):Integer;
|
|
public
|
|
constructor Create();
|
|
destructor Destroy();override;
|
|
function RegisterClass(const AElementClass : TAbstractComplexRemotableClass):TSerializeOptions;
|
|
function Find(const AElementClass : TAbstractComplexRemotableClass):TSerializeOptions;
|
|
property Count : Integer read GetCount;
|
|
property Item[AIndex : Integer] : TSerializeOptions read GetItem;
|
|
end;
|
|
|
|
var
|
|
SerializeOptionsRegistryInstance : TSerializeOptionsRegistry = nil;
|
|
|
|
function GetSerializeOptionsRegistry():TSerializeOptionsRegistry;
|
|
begin
|
|
if not Assigned(SerializeOptionsRegistryInstance) then
|
|
SerializeOptionsRegistryInstance := TSerializeOptionsRegistry.Create();
|
|
Result := SerializeOptionsRegistryInstance;
|
|
end;
|
|
|
|
{ TSerializeOptionsRegistry }
|
|
|
|
function TSerializeOptionsRegistry.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TSerializeOptionsRegistry.GetItem(AIndex : Integer): TSerializeOptions;
|
|
begin
|
|
Result := FList[AIndex] as TSerializeOptions;
|
|
end;
|
|
|
|
function TSerializeOptionsRegistry.IndexOf(
|
|
const AElementClass: TAbstractComplexRemotableClass
|
|
): Integer;
|
|
begin
|
|
for Result := 0 to Pred(Count) do begin
|
|
if ( Item[Result].ElementClass = AElementClass ) then
|
|
Exit;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
constructor TSerializeOptionsRegistry.Create();
|
|
begin
|
|
FList := TObjectList.Create(True);
|
|
end;
|
|
|
|
destructor TSerializeOptionsRegistry.Destroy();
|
|
begin
|
|
FreeAndNil(FList);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
function TSerializeOptionsRegistry.RegisterClass(
|
|
const AElementClass: TAbstractComplexRemotableClass
|
|
): TSerializeOptions;
|
|
var
|
|
i, j, k, c : Integer;
|
|
ri : TSerializeOptions;
|
|
begin
|
|
i := IndexOf(AElementClass);
|
|
if ( i < 0 ) then begin
|
|
c := FList.Count;
|
|
i := FList.Add(TSerializeOptions.Create(AElementClass));
|
|
Result := FList[i] as TSerializeOptions;
|
|
for j := 0 to Pred(c) do begin
|
|
ri := FList[j] as TSerializeOptions;
|
|
if AElementClass.InheritsFrom(ri.ElementClass) then begin
|
|
for k := 0 to Pred(ri.AttributeFieldCount) do begin
|
|
Result.FAttributeFieldList.Add(ri.FAttributeFieldList[k]);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := FList[i] as TSerializeOptions;
|
|
end;
|
|
|
|
function TSerializeOptionsRegistry.Find(const AElementClass: TAbstractComplexRemotableClass): TSerializeOptions;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
i := IndexOf(AElementClass);
|
|
if ( i >= 0 ) then
|
|
Result := FList[i] as TSerializeOptions
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TSerializeOptions }
|
|
|
|
procedure TSerializeOptions.AddAttributeField(const AAttributeField: string);
|
|
begin
|
|
if ( FAttributeFieldList.IndexOf(AAttributeField) < 0 ) then
|
|
FAttributeFieldList.Add(AAttributeField);
|
|
end;
|
|
|
|
function TSerializeOptions.GetAttributeCount: Integer;
|
|
begin
|
|
Result := FAttributeFieldList.Count;
|
|
end;
|
|
|
|
function TSerializeOptions.GetAttributeField(AIndex : Integer): string;
|
|
begin
|
|
Result := FAttributeFieldList[AIndex];
|
|
end;
|
|
|
|
constructor TSerializeOptions.Create(const AElementClass: TAbstractComplexRemotableClass);
|
|
begin
|
|
FElementClass := AElementClass;
|
|
FAttributeFieldList := TStringList.Create();
|
|
FAttributeFieldList.Duplicates := dupIgnore;
|
|
FAttributeFieldList.Sorted := True;
|
|
end;
|
|
|
|
destructor TSerializeOptions.Destroy();
|
|
begin
|
|
FreeAndNil(FAttributeFieldList);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
function TSerializeOptions.IsAttributeField(const AField: string): Boolean;
|
|
begin
|
|
Result := ( FAttributeFieldList.IndexOf(AField) >= 0 );
|
|
end;
|
|
|
|
class procedure TBaseComplexRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
{$IFDEF USE_SERIALIZE}
|
|
var
|
|
locSerializer : TObjectSerializer;
|
|
begin
|
|
locSerializer := TBaseComplexTypeRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then
|
|
locSerializer.Save(AObject,AStore,AName,ATypeInfo)
|
|
else
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
{$ELSE USE_SERIALIZE}
|
|
Var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
pt : PTypeInfo;
|
|
int64Data : Int64;
|
|
strData : String;
|
|
objData : TObject;
|
|
boolData : Boolean;
|
|
enumData : TEnumBuffer;
|
|
floatDt : TFloatBuffer;
|
|
p : PPropInfo;
|
|
oldSS,ss : TSerializationStyle;
|
|
typRegItem : TTypeRegistryItem;
|
|
prpName : string;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
AStore.BeginObject(AName,ATypeInfo);
|
|
try
|
|
if not Assigned(AObject) then begin
|
|
AStore.NilCurrentScope();
|
|
Exit;
|
|
end;
|
|
propCount := GetTypeData(ATypeInfo)^.PropCount;
|
|
if ( propCount > 0 ) then begin
|
|
propListLen := GetPropList(ATypeInfo,propList);
|
|
try
|
|
ss := AStore.GetSerializationStyle();
|
|
typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo];
|
|
for i := 0 to Pred(propCount) do begin
|
|
p := propList^[i];
|
|
pt := p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF};
|
|
if IsStoredProp(AObject,p) then begin
|
|
if IsAttributeProperty(p^.Name) then begin
|
|
if ( ss <> ssAttibuteSerialization ) then
|
|
ss := ssAttibuteSerialization;
|
|
end else begin
|
|
if ( ss <> ssNodeSerialization ) then
|
|
ss := ssNodeSerialization;
|
|
end;
|
|
if ( ss <> AStore.GetSerializationStyle() ) then
|
|
AStore.SetSerializationStyle(ss);
|
|
prpName := typRegItem.GetExternalPropertyName(p^.Name);
|
|
case pt^.Kind of
|
|
tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} :
|
|
begin
|
|
int64Data := GetInt64Prop(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,int64Data);
|
|
end;
|
|
tkLString{$IFDEF FPC},tkAString{$ENDIF} :
|
|
begin
|
|
strData := GetStrProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,strData);
|
|
end;
|
|
tkClass :
|
|
begin
|
|
objData := GetObjectProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,objData);
|
|
end;
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool :
|
|
begin
|
|
boolData := Boolean(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,boolData);
|
|
end;
|
|
{$ENDIF}
|
|
tkEnumeration,tkInteger :
|
|
begin
|
|
{$IFDEF WST_DELPHI}
|
|
if ( pt^.Kind = tkEnumeration ) and
|
|
( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
boolData := Boolean(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,boolData);
|
|
end else begin
|
|
{$ENDIF}
|
|
FillChar(enumData,SizeOf(enumData),#0);
|
|
case GetTypeData(pt)^.OrdType of
|
|
otSByte :
|
|
begin
|
|
enumData.ShortIntData := ShortInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.ShortIntData);
|
|
end;
|
|
otUByte :
|
|
begin
|
|
enumData.ByteData := Byte(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.ByteData);
|
|
end;
|
|
otSWord :
|
|
begin
|
|
enumData.SmallIntData := SmallInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.SmallIntData);
|
|
end;
|
|
otUWord :
|
|
begin
|
|
enumData.WordData := Word(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.WordData);
|
|
end;
|
|
otSLong :
|
|
begin
|
|
enumData.SLongIntData := LongInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.SLongIntData);
|
|
end;
|
|
otULong :
|
|
begin
|
|
enumData.ULongIntData := LongWord(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,enumData.ULongIntData);
|
|
end;
|
|
end;
|
|
{$IFDEF WST_DELPHI}
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
tkFloat :
|
|
begin
|
|
FillChar(floatDt,SizeOf(floatDt),#0);
|
|
case GetTypeData(pt)^.FloatType of
|
|
ftSingle :
|
|
begin
|
|
floatDt.SingleData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,floatDt.SingleData);
|
|
end;
|
|
ftDouble :
|
|
begin
|
|
floatDt.DoubleData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,floatDt.DoubleData);
|
|
end;
|
|
ftExtended :
|
|
begin
|
|
floatDt.ExtendedData := Extended(GetFloatProp(AObject,p^.Name));
|
|
AStore.Put(prpName,pt,floatDt.ExtendedData);
|
|
end;
|
|
ftCurr :
|
|
begin
|
|
floatDt.CurrencyData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,floatDt.CurrencyData);
|
|
end;
|
|
{$IFDEF HAS_COMP}
|
|
ftComp :
|
|
begin
|
|
floatDt.CompData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(prpName,pt,floatDt.CompData);
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
{$ENDIF USE_SERIALIZE}
|
|
|
|
Type
|
|
TFloatExtendedType = Extended;
|
|
class procedure TBaseComplexRemotable.Load(
|
|
Var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
{$IFDEF USE_SERIALIZE}
|
|
var
|
|
locSerializer : TObjectSerializer;
|
|
begin
|
|
locSerializer := TBaseComplexTypeRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then
|
|
locSerializer.Read(AObject,AStore,AName,ATypeInfo)
|
|
else
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
{$ELSE USE_SERIALIZE}
|
|
Var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
pt : PTypeInfo;
|
|
propName : String;
|
|
int64Data : Int64;
|
|
strData : String;
|
|
objData : TObject;
|
|
objDataCreateHere : Boolean;
|
|
boolData : Boolean;
|
|
p : PPropInfo;
|
|
enumData : TEnumBuffer;
|
|
floatDt : TFloatExtendedType;
|
|
floatBuffer : TFloatBuffer;
|
|
persistType : TPropStoreType;
|
|
objTypeData : PTypeData;
|
|
oldSS,ss : TSerializationStyle;
|
|
typRegItem : TTypeRegistryItem;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
if ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin
|
|
try
|
|
if AStore.IsCurrentScopeNil() then
|
|
Exit; // ???? FreeAndNil(AObject);
|
|
If Not Assigned(AObject) Then
|
|
AObject := Create();
|
|
objTypeData := GetTypeData(ATypeInfo);
|
|
propCount := objTypeData^.PropCount;
|
|
If ( propCount > 0 ) Then Begin
|
|
propListLen := GetPropList(ATypeInfo,propList);
|
|
Try
|
|
typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo];
|
|
For i := 0 To Pred(propCount) Do Begin
|
|
p := propList^[i];
|
|
persistType := IsStoredPropClass(objTypeData^.ClassType,p);
|
|
If ( persistType in [pstOptional,pstAlways] ) Then Begin
|
|
pt := p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF};
|
|
propName := typRegItem.GetExternalPropertyName(p^.Name);
|
|
if IsAttributeProperty(p^.Name) then begin
|
|
ss := ssAttibuteSerialization;
|
|
end else begin
|
|
ss := ssNodeSerialization;
|
|
end;
|
|
if ( ss <> AStore.GetSerializationStyle() ) then
|
|
AStore.SetSerializationStyle(ss);
|
|
try
|
|
Case pt^.Kind Of
|
|
tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} :
|
|
begin
|
|
AStore.Get(pt,propName,int64Data);
|
|
SetInt64Prop(AObject,p^.Name,int64Data);
|
|
end;
|
|
tkLString{$IFDEF FPC}, tkAString{$ENDIF} :
|
|
Begin
|
|
AStore.Get(pt,propName,strData);
|
|
SetStrProp(AObject,p^.Name,strData);
|
|
End;
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool :
|
|
Begin
|
|
AStore.Get(pt,propName,boolData);
|
|
SetOrdProp(AObject,p^.Name,Ord(boolData));
|
|
End;
|
|
{$ENDIF}
|
|
tkClass :
|
|
Begin
|
|
objData := GetObjectProp(AObject,p^.Name);
|
|
objDataCreateHere := not Assigned(objData);
|
|
try
|
|
AStore.Get(pt,propName,objData);
|
|
if objDataCreateHere then
|
|
SetObjectProp(AObject,p^.Name,objData);
|
|
finally
|
|
if objDataCreateHere and ( objData <> GetObjectProp(AObject,p^.Name) ) then
|
|
FreeAndNil(objData);
|
|
end;
|
|
End;
|
|
tkEnumeration,tkInteger :
|
|
Begin
|
|
{$IFDEF WST_DELPHI}
|
|
if ( pt^.Kind = tkEnumeration ) and
|
|
( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
AStore.Get(pt,propName,boolData);
|
|
SetPropValue(AObject,p^.Name,boolData);
|
|
end else begin
|
|
{$ENDIF}
|
|
FillChar(enumData,SizeOf(enumData),#0);
|
|
Case GetTypeData(pt)^.OrdType Of
|
|
otSByte :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ShortIntData);
|
|
int64Data := enumData.ShortIntData;
|
|
End;
|
|
otUByte :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ByteData);
|
|
int64Data := enumData.ByteData;
|
|
End;
|
|
otSWord :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.SmallIntData);
|
|
int64Data := enumData.SmallIntData;
|
|
End;
|
|
otUWord :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.WordData);
|
|
int64Data := enumData.WordData;
|
|
End;
|
|
otSLong:
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.SLongIntData);
|
|
int64Data := enumData.SLongIntData;
|
|
End;
|
|
otULong :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ULongIntData);
|
|
int64Data := enumData.ULongIntData;
|
|
End;
|
|
End;
|
|
SetOrdProp(AObject,p^.Name,int64Data);
|
|
{$IFDEF WST_DELPHI}
|
|
end;
|
|
{$ENDIF}
|
|
End;
|
|
tkFloat :
|
|
Begin
|
|
FillChar(floatDt,SizeOf(floatBuffer),#0);
|
|
Case GetTypeData(pt)^.FloatType Of
|
|
ftSingle :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.SingleData);
|
|
floatDt := floatBuffer.SingleData;
|
|
End;
|
|
ftDouble :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.DoubleData);
|
|
floatDt := floatBuffer.DoubleData;
|
|
End;
|
|
ftExtended :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.ExtendedData);
|
|
floatDt := floatBuffer.ExtendedData;
|
|
End;
|
|
ftCurr :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.CurrencyData);
|
|
floatDt := floatBuffer.CurrencyData;
|
|
End;
|
|
ftComp :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.CompData);
|
|
floatDt := floatBuffer.CompData;
|
|
End;
|
|
End;
|
|
SetFloatProp(AObject,p^.Name,floatDt);
|
|
End;
|
|
End;
|
|
except
|
|
on E : EServiceException do begin
|
|
if ( persistType = pstAlways ) then
|
|
raise;
|
|
end;
|
|
end;
|
|
End;
|
|
End;
|
|
Finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
End;
|
|
End;
|
|
finally
|
|
AStore.EndScopeRead();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF USE_SERIALIZE}
|
|
|
|
{ TBaseObjectArrayRemotable }
|
|
|
|
function TBaseObjectArrayRemotable.GetItem(AIndex: Integer): TBaseRemotable;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FArray[AIndex];
|
|
end;
|
|
|
|
function TBaseObjectArrayRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FArray);
|
|
end;
|
|
|
|
class procedure TBaseObjectArrayRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
Var
|
|
itmTypInfo : PTypeInfo;
|
|
i, arrayLen : Integer;
|
|
nativObj : TBaseObjectArrayRemotable;
|
|
itm : TObject;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
if ( AObject <> nil ) then begin
|
|
Assert(AObject.InheritsFrom(TBaseObjectArrayRemotable));
|
|
nativObj := AObject as TBaseObjectArrayRemotable;
|
|
arrayLen := nativObj.Length;
|
|
styl := GetStyle();
|
|
if ( arrayLen > 0 ) then begin
|
|
itmTypInfo := PTypeInfo(GetItemClass().ClassInfo);
|
|
AStore.BeginArray(AName,PTypeInfo(Self.ClassInfo),itmTypInfo,[0,Pred(arrayLen)],styl);
|
|
try
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
for i := 0 to Pred(arrayLen) do begin
|
|
itm := nativObj.Item[i];
|
|
AStore.Put(itmName,itmTypInfo,itm);
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end else if ( styl = asScoped ) and ( ioAlwaysSerialize in nativObj.Options ) then begin
|
|
AStore.BeginArray(
|
|
AName, PTypeInfo(Self.ClassInfo),
|
|
PTypeInfo(GetItemClass().ClassInfo),[0,-1],styl
|
|
);
|
|
try
|
|
AStore.NilCurrentScope();
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class procedure TBaseObjectArrayRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
Var
|
|
i, len : Integer;
|
|
nativObj : TBaseObjectArrayRemotable;
|
|
s : string;
|
|
itmTypInfo : PTypeInfo;
|
|
itm : TBaseRemotable;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
styl := GetStyle();
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
if (AObject = nil) then
|
|
AObject := Create();
|
|
len := AStore.BeginArrayRead(AName,ATypeInfo,styl,itmName);
|
|
if ( len >= 0 ) then begin
|
|
Try
|
|
itmTypInfo := PTypeInfo(GetItemClass().ClassInfo);
|
|
nativObj := AObject as TBaseObjectArrayRemotable;
|
|
If ( len > 0 ) Then Begin
|
|
s := '';
|
|
nativObj.SetLength(len);
|
|
For i := 0 To Pred(len) Do Begin
|
|
itm := nativObj[i];
|
|
AStore.Get(itmTypInfo,s,itm);
|
|
End;
|
|
End;
|
|
Finally
|
|
AStore.EndScopeRead();
|
|
End;
|
|
end else begin
|
|
if ( AObject <> nil ) then
|
|
(AObject as TBaseObjectArrayRemotable).SetLength(0);
|
|
end;
|
|
end;
|
|
|
|
class function TBaseObjectArrayRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result:= GetItemClass().ClassInfo;
|
|
end;
|
|
|
|
constructor TBaseObjectArrayRemotable.Create();
|
|
begin
|
|
FArray := Nil;
|
|
end;
|
|
|
|
procedure TBaseObjectArrayRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TBaseObjectArrayRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) then begin
|
|
if Source.InheritsFrom(TBaseObjectArrayRemotable) then begin
|
|
src := TBaseObjectArrayRemotable(Source);
|
|
c := src.Length;
|
|
SetLength(c);
|
|
for i := 0 to Pred(c) do begin
|
|
Item[i].Assign(src.Item[i]);
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end else begin
|
|
SetLength(0);
|
|
end;
|
|
end;
|
|
|
|
function TBaseObjectArrayRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
var
|
|
i, c : Integer;
|
|
dst : TBaseObjectArrayRemotable;
|
|
begin
|
|
if ( Self = ACompareTo ) then begin
|
|
Result := True;
|
|
end else begin
|
|
Result := ( Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TBaseObjectArrayRemotable) and
|
|
( Self.Length = TBaseObjectArrayRemotable(ACompareTo).Length ) and
|
|
( TBaseObjectArrayRemotable(ACompareTo).GetItemClass().InheritsFrom(Self.GetItemClass()) )
|
|
) ;
|
|
if Result and ( Self.Length > 0 ) then begin
|
|
dst := TBaseObjectArrayRemotable(ACompareTo);
|
|
c := Self.Length;
|
|
for i := 0 to Pred(c) do begin
|
|
if not Self.Item[i].Equal(dst.Item[i]) then begin
|
|
Result := False;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseObjectArrayRemotable.SetLength(const ANewSize: Integer);
|
|
var
|
|
i,oldLen : Integer;
|
|
itmClss : TBaseRemotableClass;
|
|
begin
|
|
oldLen := GetLength;
|
|
if ( oldLen = ANewSize ) then
|
|
Exit;
|
|
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
|
|
if ( oldLen > ANewSize ) then begin
|
|
for i := ANewSize to Pred(oldLen) do
|
|
FreeAndNil(FArray[i]);
|
|
System.SetLength(FArray,ANewSize);
|
|
end else begin
|
|
System.SetLength(FArray,ANewSize);
|
|
itmClss := GetItemClass();
|
|
for i := oldLen to Pred(ANewSize) do
|
|
FArray[i] := itmClss.Create();
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseObjectArrayRemotable.Exchange(const Index1, Index2: Integer);
|
|
var
|
|
tmp : TBaseRemotable;
|
|
begin
|
|
if ( Index1 <> Index2 ) then begin
|
|
CheckIndex(Index1);
|
|
CheckIndex(Index2);
|
|
tmp := FArray[Index1];
|
|
FArray[Index1] := FArray[Index2];
|
|
FArray[Index2] := tmp;
|
|
end;
|
|
end;
|
|
|
|
{ TBaseFactoryRegistryItem }
|
|
|
|
constructor TBaseFactoryRegistryItem.Create(
|
|
const AName : string;
|
|
const AFactory : IItemFactory
|
|
);
|
|
begin
|
|
Assert(Assigned(AFactory));
|
|
FName := AName;
|
|
FFactory := AFactory;
|
|
end;
|
|
|
|
destructor TBaseFactoryRegistryItem.Destroy();
|
|
begin
|
|
FName := '';
|
|
FFactory := nil;
|
|
inherited Destroy();
|
|
end;
|
|
|
|
function TBaseFactoryRegistry.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TBaseFactoryRegistry.GetItem(Index: Integer): TBaseFactoryRegistryItem;
|
|
begin
|
|
Result := FList[Index] as TBaseFactoryRegistryItem;
|
|
end;
|
|
|
|
{ TBaseFactoryRegistry }
|
|
function TBaseFactoryRegistry.FindFactory(const AName: string): IItemFactory;
|
|
Var
|
|
i , c : Integer;
|
|
s : string;
|
|
begin
|
|
s := LowerCase(Trim(AName));
|
|
c := Pred(FList.Count);
|
|
For i := 0 To c Do Begin
|
|
If AnsiSameText(TBaseFactoryRegistryItem(FList[i]).Name,s) Then Begin
|
|
Result := TBaseFactoryRegistryItem(FList[i]).Factory;
|
|
Exit;
|
|
End;
|
|
End;
|
|
Result := Nil;
|
|
end;
|
|
|
|
procedure TBaseFactoryRegistry.Register(
|
|
const AName : string;
|
|
AFactory : IItemFactory
|
|
);
|
|
begin
|
|
Assert(Assigned(AFactory));
|
|
If Not Assigned(FindFactory(AName)) Then
|
|
FList.Add(TBaseFactoryRegistryItem.Create(AName,AFactory));
|
|
end;
|
|
|
|
constructor TBaseFactoryRegistry.Create();
|
|
begin
|
|
inherited Create();
|
|
FList := TObjectList.Create(True);
|
|
end;
|
|
|
|
destructor TBaseFactoryRegistry.Destroy();
|
|
begin
|
|
FList.Free();
|
|
inherited Destroy();
|
|
end;
|
|
|
|
{ TSimpleItemFactory }
|
|
|
|
function TSimpleItemFactory.CreateInstance(): IInterface;
|
|
begin
|
|
Result := FItemClass.Create() as IInterface;
|
|
end;
|
|
|
|
function TSimpleItemFactory.GetItemClass(): TSimpleFactoryItemClass;
|
|
begin
|
|
Result := FItemClass;
|
|
end;
|
|
|
|
constructor TSimpleItemFactory.Create(AItemClass: TSimpleFactoryItemClass);
|
|
begin
|
|
if not Assigned(AItemClass) then
|
|
raise EServiceConfigException.CreateFmt(SERR_InvalidParameterProc,['AItemClass','TSimpleItemFactory.Create()']);
|
|
FItemClass := AItemClass;
|
|
end;
|
|
|
|
{ TSimpleItemFactoryEx }
|
|
|
|
procedure TSimpleItemFactoryEx.PreparePool();
|
|
begin
|
|
if ( FPool = nil ) then begin
|
|
FPool := TIntfPool.Create(PoolMin,PoolMax,TSimpleItemFactory.Create(FItemClass));
|
|
end;
|
|
end;
|
|
|
|
procedure TSimpleItemFactoryEx.SetPooled(const AValue: Boolean);
|
|
begin
|
|
if ( FPooled = AValue ) then
|
|
Exit;
|
|
FreeAndNil(FPool);
|
|
if AValue then begin
|
|
if ( PoolMin < 0 ) or ( PoolMin > PoolMax ) or ( PoolMax < 1 ) then
|
|
raise EServiceException.CreateFmt(SERR_InvalidPoolParametersArgs,[PoolMin,PoolMax]);
|
|
PreparePool();
|
|
end;
|
|
FPooled := AValue;
|
|
end;
|
|
|
|
procedure TSimpleItemFactoryEx.SetPoolMax(const AValue: Integer);
|
|
begin
|
|
if ( FPoolMax = AValue ) then
|
|
Exit;
|
|
if Pooled then
|
|
raise EServiceException.Create(SERR_OperationNotAllowedOnActivePool);
|
|
FPoolMax := AValue;
|
|
end;
|
|
|
|
procedure TSimpleItemFactoryEx.SetPoolMin(const AValue: Integer);
|
|
begin
|
|
if ( FPoolMin = AValue ) then
|
|
Exit;
|
|
if Pooled then
|
|
raise EServiceException.Create(SERR_OperationNotAllowedOnActivePool);
|
|
FPoolMin := AValue;
|
|
end;
|
|
|
|
function TSimpleItemFactoryEx.CreateInstance(): IInterface;
|
|
begin
|
|
if Pooled then begin
|
|
Result := FPool.Get(TimeOut);
|
|
end else begin
|
|
Result := inherited CreateInstance();
|
|
end;
|
|
end;
|
|
|
|
procedure TSimpleItemFactoryEx.ReleaseInstance(const AInstance : IInterface);
|
|
begin
|
|
if Pooled then begin
|
|
FPool.Release(AInstance);
|
|
end;
|
|
end;
|
|
|
|
procedure TSimpleItemFactoryEx.DiscardInstance(const AInstance : IInterface);
|
|
begin
|
|
if Pooled then
|
|
FPool.Discard(AInstance);
|
|
end;
|
|
|
|
function TSimpleItemFactoryEx.GetPropertyManager(
|
|
const APropertyGroup : string;
|
|
const ACreateIfNotExists : Boolean
|
|
):IPropertyManager;
|
|
var
|
|
i : Integer;
|
|
s : string;
|
|
begin
|
|
Result := nil;
|
|
s := Trim(APropertyGroup);
|
|
i := FPropertyNames.IndexOf(s);
|
|
if ( i < 0 ) then begin
|
|
if not ACreateIfNotExists then
|
|
Exit;
|
|
i := FPropertyNames.Add(s);
|
|
if ( s = '' ) then
|
|
FProperties.Add(TPublishedPropertyManager.Create(Self))
|
|
else
|
|
FProperties.Add(TStoredPropertyManager.Create());
|
|
end;
|
|
Result := FProperties.Get(i) as IPropertyManager;
|
|
end;
|
|
|
|
constructor TSimpleItemFactoryEx.Create(
|
|
AItemClass : TSimpleFactoryItemClass;
|
|
const APropsString : string
|
|
);
|
|
begin
|
|
inherited Create(AItemClass);
|
|
FPropertyNames := TStringList.Create();
|
|
FProperties := TInterfaceList.Create();
|
|
if ( Length(APropsString) > 0 ) then begin
|
|
GetPropertyManager('',True).SetProperties(APropsString);
|
|
end;
|
|
end;
|
|
|
|
constructor TSimpleItemFactoryEx.Create(AItemClass: TSimpleFactoryItemClass);
|
|
begin
|
|
Create(AItemClass,'');
|
|
end;
|
|
|
|
destructor TSimpleItemFactoryEx.Destroy();
|
|
begin
|
|
FreeAndNil(FPropertyNames);
|
|
FProperties := nil;
|
|
FreeAndNil(FPool);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
{ TSimpleFactoryItem }
|
|
|
|
constructor TSimpleFactoryItem.Create();
|
|
begin
|
|
end;
|
|
|
|
|
|
{ TSimpleCallContext }
|
|
|
|
procedure TSimpleCallContext.Clear();
|
|
begin
|
|
FHeaderList.Clear();
|
|
FFreeObjectList.Clear();;
|
|
end;
|
|
|
|
procedure TSimpleCallContext.AddObjectToFree(const AObject: TObject);
|
|
begin
|
|
if ( FFreeObjectList.IndexOf(AObject) < 0 ) then
|
|
FFreeObjectList.Add(AObject);
|
|
end;
|
|
|
|
function TSimpleCallContext.AddHeader(
|
|
const AHeader: THeaderBlock;
|
|
const AKeepOwnership: Boolean
|
|
): Integer;
|
|
begin
|
|
Result := FHeaderList.IndexOf(AHeader);
|
|
if ( Result = -1 ) then
|
|
Result := FHeaderList.Add(AHeader);
|
|
if AKeepOwnership then
|
|
AddObjectToFree(AHeader);
|
|
end;
|
|
|
|
function TSimpleCallContext.AddHeader(
|
|
const AHeader : TBaseRemotable;
|
|
const AKeepOwnership : Boolean;
|
|
const AName : string = ''
|
|
) : Integer;
|
|
var
|
|
locProxy : THeaderBlockProxy;
|
|
begin
|
|
if ( AHeader <> nil ) then begin
|
|
if AHeader.InheritsFrom(THeaderBlock) then begin
|
|
if not IsStrEmpty(AName) then
|
|
THeaderBlock(AHeader).Name := AName;
|
|
Result := AddHeader(THeaderBlock(AHeader),AKeepOwnership);
|
|
end else begin
|
|
locProxy := THeaderBlockProxy.Create();
|
|
locProxy.ActualObject := AHeader;
|
|
locProxy.OwnObject := AKeepOwnership;
|
|
if not IsStrEmpty(AName) then
|
|
locProxy.Name := AName;
|
|
Result := AddHeader(locProxy,True);
|
|
end;
|
|
end else begin
|
|
locProxy := THeaderBlockProxy.Create();
|
|
if not IsStrEmpty(AName) then
|
|
locProxy.Name := AName;
|
|
Result := AddHeader(locProxy,True);
|
|
end;
|
|
end;
|
|
|
|
function TSimpleCallContext.GetHeaderCount(const ADirections : THeaderDirections):Integer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if ( ADirections = [Low(THeaderDirection)..High(THeaderDirection)] ) then
|
|
Result := FHeaderList.Count
|
|
else begin
|
|
Result := 0;
|
|
for i := 0 to Pred(FHeaderList.Count) do begin
|
|
if ( THeaderBlock(FHeaderList[i]).Direction in ADirections ) then
|
|
Inc(Result);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TSimpleCallContext.GetHeader(const AIndex: Integer): THeaderBlock;
|
|
begin
|
|
Result := FHeaderList[AIndex] as THeaderBlock;
|
|
end;
|
|
|
|
procedure TSimpleCallContext.ClearHeaders(const ADirection: THeaderDirection);
|
|
var
|
|
i, c : Integer;
|
|
h : THeaderBlock;
|
|
fl : TObjectList;
|
|
begin
|
|
c := FHeaderList.Count;
|
|
if ( c > 0 ) then begin
|
|
fl := TObjectList.Create(False);
|
|
try
|
|
for i := 0 to Pred(c) do begin
|
|
h := FHeaderList[i] as THeaderBlock;
|
|
if ( h.Direction = ADirection ) then
|
|
fl.Add(h);
|
|
end;
|
|
for i := 0 to Pred(fl.Count) do
|
|
FreeHeader(fl[i] as THeaderBlock);
|
|
finally
|
|
fl.Free();
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TSimpleCallContext.FreeHeader(AHeader: THeaderBlock);
|
|
begin
|
|
if Assigned(AHeader) then begin
|
|
if ( FHeaderList.IndexOf(AHeader) >= 0 ) then
|
|
FHeaderList.Remove(AHeader);
|
|
if ( FFreeObjectList.IndexOf(AHeader) >= 0 ) then
|
|
FHeaderList.Remove(AHeader)
|
|
else
|
|
AHeader.Free();
|
|
end;
|
|
end;
|
|
|
|
function TSimpleCallContext.GetPropertyManager(): IPropertyManager;
|
|
begin
|
|
Result := FPropertyManager;
|
|
end;
|
|
|
|
constructor TSimpleCallContext.Create();
|
|
begin
|
|
FHeaderList := TObjectList.Create(False);
|
|
FFreeObjectList := TObjectList.Create(True);
|
|
FPropertyManager := TStoredPropertyManager.Create();
|
|
end;
|
|
|
|
destructor TSimpleCallContext.Destroy();
|
|
begin
|
|
FreeAndNil(FHeaderList);
|
|
FreeAndNil(FFreeObjectList);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
{ TTypeRegistryItem }
|
|
|
|
procedure TTypeRegistryItem.SetOptions(AValue: TTypeRegistryItemOptions);
|
|
begin
|
|
if (FOptions = AValue) then
|
|
Exit;
|
|
FOptions := AValue;
|
|
Init();
|
|
end;
|
|
|
|
procedure TTypeRegistryItem.Init();
|
|
begin
|
|
|
|
end;
|
|
|
|
function TTypeRegistryItem.IndexOfProp(
|
|
const AName: string;
|
|
const ANameType : TPropertyNameType
|
|
) : Integer;
|
|
var
|
|
i : Integer;
|
|
locName : string;
|
|
begin
|
|
Result := -1;
|
|
if ( FProperties <> nil ) and ( FProperties.Count > 0 ) then begin
|
|
locName := LowerCase(AName);
|
|
if ( ANameType = pntInternalName ) then begin
|
|
for i := 0 to Pred(FProperties.Count) do begin
|
|
if ( locName = LowerCase(TPropertyItem(FProperties[i]).InternalName) ) then begin
|
|
Result := i;
|
|
Break;
|
|
end;
|
|
end;
|
|
end else begin
|
|
for i := 0 to Pred(FProperties.Count) do begin
|
|
if ( locName = LowerCase(TPropertyItem(FProperties[i]).ExternalName) ) then begin
|
|
Result := i;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TTypeRegistryItem.FindProperty(
|
|
const AName: string;
|
|
const ANameType : TPropertyNameType
|
|
) : TPropertyItem;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
i := IndexOfProp(AName,ANameType);
|
|
if ( i = -1 ) then
|
|
Result := nil
|
|
else
|
|
Result := TPropertyItem(FProperties[i]);
|
|
end;
|
|
|
|
constructor TTypeRegistryItem.Create(AOwner: TTypeRegistry; ANameSpace: string;
|
|
ADataType: PTypeInfo; const ADeclaredName: string);
|
|
begin
|
|
FOwner := AOwner;
|
|
FNameSpace := ANameSpace;
|
|
FDataType := ADataType;
|
|
FDeclaredName := Trim(ADeclaredName);
|
|
If ( Length(FDeclaredName) = 0 ) Then
|
|
FDeclaredName := FDataType^.Name;
|
|
end;
|
|
|
|
destructor TTypeRegistryItem.Destroy();
|
|
begin
|
|
FreeAndNil(FProperties);
|
|
FPascalSynonyms.Free();
|
|
FExternalSynonyms.Free();
|
|
inherited Destroy();
|
|
end;
|
|
|
|
function TTypeRegistryItem.AddPascalSynonym(const ASynonym: string):TTypeRegistryItem;
|
|
begin
|
|
Result := Self;
|
|
if AnsiSameText(ASynonym,DataType^.Name) then
|
|
Exit;
|
|
if not Assigned(FPascalSynonyms) then begin
|
|
FPascalSynonyms := TStringList.Create();
|
|
FPascalSynonyms.Add(FDataType^.Name);
|
|
end;
|
|
if ( FPascalSynonyms.IndexOf(ASynonym) = -1 ) then
|
|
FPascalSynonyms.Add(AnsiLowerCase(ASynonym));
|
|
end;
|
|
|
|
function TTypeRegistryItem.AddExternalSynonym(const ASynonym: string): TTypeRegistryItem;
|
|
begin
|
|
Result := Self;
|
|
if AnsiSameText(ASynonym,DataType^.Name) then
|
|
Exit;
|
|
if not Assigned(FExternalSynonyms) then begin
|
|
FExternalSynonyms := TStringList.Create();
|
|
FExternalSynonyms.Add(Self.DeclaredName);
|
|
end;
|
|
if ( FExternalSynonyms.IndexOf(ASynonym) = -1 ) then
|
|
FExternalSynonyms.Add(AnsiLowerCase(ASynonym));
|
|
end;
|
|
|
|
function TTypeRegistryItem.IsSynonym(const APascalTypeName: string): Boolean;
|
|
begin
|
|
Result := AnsiSameText(APascalTypeName,DataType^.Name);
|
|
if ( not Result ) and Assigned(FPascalSynonyms) then
|
|
Result := ( FPascalSynonyms.IndexOf(APascalTypeName) >= 0 ) ;
|
|
end;
|
|
|
|
function TTypeRegistryItem.IsExternalSynonym(const AExternalName: string): Boolean;
|
|
begin
|
|
Result := AnsiSameText(AExternalName,Self.DeclaredName);
|
|
if ( not Result ) and Assigned(FExternalSynonyms) then
|
|
Result := ( FExternalSynonyms.IndexOf(AExternalName) >= 0 ) ;
|
|
end;
|
|
|
|
procedure TTypeRegistryItem.RegisterExternalPropertyName(const APropName,AExtPropName: string);
|
|
var
|
|
i : Integer;
|
|
po : TPropertyItem;
|
|
begin
|
|
i := IndexOfProp(APropName,pntInternalName);
|
|
if ( i = -1 ) then begin
|
|
if ( FProperties = nil ) then
|
|
FProperties := TObjectList.Create(True);
|
|
po := TPropertyItem.Create();
|
|
FProperties.Add(po);
|
|
po.FInternalName := APropName;
|
|
//po.FOptions := Self.DefaultPropertyOptions;
|
|
end else begin
|
|
po := TPropertyItem(FProperties[i]);
|
|
end;
|
|
po.FExternalName := AExtPropName;
|
|
end;
|
|
|
|
procedure TTypeRegistryItem.RegisterObject(const APropName : string; const AObject : TObject);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
i := IndexOfProp(APropName,pntInternalName);
|
|
if ( i = -1 ) then begin
|
|
RegisterExternalPropertyName(APropName,APropName);
|
|
i := IndexOfProp(APropName,pntInternalName);
|
|
end;
|
|
TPropertyItem(FProperties[i]).FExtObject := AObject;
|
|
end;
|
|
|
|
function TTypeRegistryItem.GetObject(const APropName : string) : TObject;
|
|
var
|
|
p : TPropertyItem;
|
|
begin
|
|
p := FindProperty(APropName,pntInternalName);
|
|
if ( p = nil ) then
|
|
Result := nil
|
|
else
|
|
Result := p.ExtObject;
|
|
end;
|
|
|
|
function TTypeRegistryItem.GetExternalPropertyName(const APropName: string): string;
|
|
var
|
|
p : TPropertyItem;
|
|
begin
|
|
p := FindProperty(APropName,pntInternalName);
|
|
if ( p = nil ) then
|
|
Result := APropName
|
|
else
|
|
Result := p.ExternalName;
|
|
end;
|
|
|
|
function TTypeRegistryItem.GetInternalPropertyName(const AExtPropName: string): string;
|
|
var
|
|
p : TPropertyItem;
|
|
begin
|
|
p := FindProperty(AExtPropName,pntExternalName);
|
|
if ( p = nil ) then
|
|
Result := AExtPropName
|
|
else
|
|
Result := p.InternalName;
|
|
end;
|
|
|
|
procedure TTypeRegistryItem.SetPropertyOptions(
|
|
const APropName: string;
|
|
const AOptions: TTypeRegistryItemOptions
|
|
);
|
|
var
|
|
po : TPropertyItem;
|
|
begin
|
|
po := FindProperty(APropName,pntInternalName);
|
|
if ( po = nil ) then begin
|
|
RegisterExternalPropertyName(APropName,APropName);
|
|
po := FindProperty(APropName,pntInternalName);
|
|
end;
|
|
po.FOptions := AOptions;
|
|
end;
|
|
|
|
procedure TTypeRegistryItem.AddOptions(
|
|
const AOptions: TTypeRegistryItemOptions
|
|
);
|
|
begin
|
|
Options := Options + AOptions;
|
|
end;
|
|
|
|
{ TTypeRegistry }
|
|
|
|
function TTypeRegistry.GetItemClassFor(const ATypeInfo : PTypeInfo) : TTypeRegistryItemClass;
|
|
var
|
|
i, c : Integer;
|
|
locInitializer : TRemotableTypeInitializerClass;
|
|
begin
|
|
Result := TTypeRegistryItem;
|
|
c := FInitializerList.Count;
|
|
if ( c > 0 ) then begin
|
|
for i := Pred(c) downto 0 do begin
|
|
locInitializer := TRemotableTypeInitializerClass(FInitializerList[i]);
|
|
if locInitializer.CanHandle(ATypeInfo) then begin
|
|
Result := locInitializer.GetItemClass(ATypeInfo);
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF TRemotableTypeInitializer_Initialize}
|
|
procedure TTypeRegistry.InitializeItem(AItem : TTypeRegistryItem);
|
|
var
|
|
i, c : Integer;
|
|
locInitializer : TRemotableTypeInitializerClass;
|
|
begin
|
|
c := FInitializerList.Count;
|
|
if ( c > 0 ) then begin
|
|
for i := Pred(c) downto 0 do begin
|
|
locInitializer := TRemotableTypeInitializerClass(FInitializerList[i]);
|
|
if locInitializer.CanHandle(AItem.DataType) and locInitializer.Initialize(AItem.DataType,AItem) then
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF TRemotableTypeInitializer_Initialize}
|
|
|
|
function TTypeRegistry.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TTypeRegistry.GetItemByIndex(Index: Integer): TTypeRegistryItem;
|
|
begin
|
|
Result := FList[Index] as TTypeRegistryItem;
|
|
end;
|
|
|
|
function TTypeRegistry.GetItemByTypeInfo(Index: PTypeInfo): TTypeRegistryItem;
|
|
Var
|
|
i : Integer;
|
|
begin
|
|
Assert(Assigned(Index));
|
|
i := IndexOf(Index);
|
|
If ( i > -1 ) Then
|
|
Result := FList[i] as TTypeRegistryItem
|
|
Else
|
|
Raise ETypeRegistryException.CreateFmt(SERR_TypeNotRegistered,[Index^.Name])
|
|
end;
|
|
|
|
constructor TTypeRegistry.Create();
|
|
begin
|
|
Inherited Create();
|
|
FList := TObjectList.Create(True);
|
|
FInitializerList := TClassList.Create();
|
|
end;
|
|
|
|
destructor TTypeRegistry.Destroy();
|
|
begin
|
|
FInitializerList.Free();
|
|
FList.Free();
|
|
inherited Destroy();
|
|
end;
|
|
|
|
procedure TTypeRegistry.RegisterInitializer(AInitializer : TRemotableTypeInitializerClass);
|
|
begin
|
|
if ( FInitializerList.IndexOf(AInitializer) = -1 ) then
|
|
FInitializerList.Add(AInitializer);
|
|
end;
|
|
|
|
function TTypeRegistry.IndexOf(const ATypeInfo: PTypeInfo): Integer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := 0 to Pred(Count) do begin
|
|
if ( ATypeInfo = Item[i].DataType ) then begin
|
|
Result := i;
|
|
Exit;
|
|
end;
|
|
{If ( ATypeInfo^.Kind = Item[Result].DataType^.Kind ) And
|
|
AnsiSameText(ATypeInfo^.Name,Item[Result].DataType^.Name)
|
|
Then
|
|
Exit;}
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function TTypeRegistry.Add(AItem: TTypeRegistryItem): Integer;
|
|
begin
|
|
Result := IndexOf(AItem.DataType);
|
|
If ( Result = -1 ) Then
|
|
Result := FList.Add(AItem)
|
|
Else
|
|
Raise ETypeRegistryException.CreateFmt(SERR_TypeNotRegistered,[AItem.DataType^.Name]);
|
|
end;
|
|
|
|
function TTypeRegistry.Register(
|
|
const ANameSpace : string;
|
|
const ADataType : PTypeInfo;
|
|
const ADeclaredName : string;
|
|
const AOptions : TTypeRegistryItemOptions
|
|
): TTypeRegistryItem;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
i := IndexOf(ADataType);
|
|
if ( i = -1 ) then begin
|
|
Result := GetItemClassFor(ADataType).Create(Self,ANameSpace,ADataType,ADeclaredName);
|
|
Add(Result);
|
|
Result.FOptions := Result.FOptions + AOptions;
|
|
Result.Init();
|
|
{$IFDEF TRemotableTypeInitializer_Initialize}
|
|
InitializeItem(Result);
|
|
{$ENDIF TRemotableTypeInitializer_Initialize}
|
|
end else begin
|
|
Result := Item[i];
|
|
end;
|
|
end;
|
|
|
|
function TTypeRegistry.Register(
|
|
const ANameSpace : string;
|
|
const ADataType : PTypeInfo;
|
|
const ADeclaredName : string
|
|
) : TTypeRegistryItem;
|
|
begin
|
|
Result := Register(ANameSpace,ADataType,ADeclaredName,[]);
|
|
end;
|
|
|
|
function TTypeRegistry.Find(ATypeInfo: PTypeInfo; const AExact: Boolean
|
|
): TTypeRegistryItem;
|
|
Var
|
|
i : Integer;
|
|
searchClass : TClass;
|
|
begin
|
|
Result := Nil;
|
|
i := IndexOf(ATypeInfo);
|
|
if ( i > -1 ) then begin
|
|
Result := Item[i]
|
|
end else if ( not AExact ) and Assigned(ATypeInfo) and ( ATypeInfo^.Kind = tkClass ) then begin
|
|
searchClass := GetTypeData(ATypeInfo)^.ClassType;
|
|
for i := Pred(Count) downto 0 do begin
|
|
Result := Item[i];
|
|
if ( Result.DataType^.Kind = tkClass ) and
|
|
searchClass.InheritsFrom(GetTypeData(Result.DataType)^.ClassType)
|
|
then begin
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := Nil;
|
|
end;
|
|
end;
|
|
|
|
function TTypeRegistry.Find(const APascalTypeName: string): TTypeRegistryItem;
|
|
var
|
|
i,c : Integer;
|
|
begin
|
|
c := Count;
|
|
for i := 0 to Pred(c) do begin
|
|
Result := Item[i];
|
|
if Result.IsSynonym(APascalTypeName) then
|
|
Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function TTypeRegistry.FindByDeclaredName(
|
|
const ATypeName,
|
|
ANameSpace : string;
|
|
const AOptions : TTypeRegistrySearchOptions
|
|
): TTypeRegistryItem;
|
|
var
|
|
i, c : Integer;
|
|
begin
|
|
{ The external synonym is not tested in the first loop so that the declared
|
|
names are _first_ search for.
|
|
}
|
|
c := Count;
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Result := Item[i];
|
|
if AnsiSameText(ANameSpace,Result.NameSpace) and
|
|
AnsiSameText(ATypeName,Result.DeclaredName)
|
|
then
|
|
Exit;
|
|
end;
|
|
if ( trsoIncludeExternalSynonyms in AOptions ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Result := Item[i];
|
|
if AnsiSameText(ANameSpace,Result.NameSpace) and
|
|
Result.IsExternalSynonym(ATypeName)
|
|
then
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
|
|
{ TBaseSimpleTypeArrayRemotable }
|
|
|
|
|
|
class procedure TBaseSimpleTypeArrayRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
i, arrayLen : Integer;
|
|
nativObj : TBaseSimpleTypeArrayRemotable;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
if Assigned(AObject) then begin
|
|
Assert(AObject.InheritsFrom(TBaseSimpleTypeArrayRemotable));
|
|
nativObj := AObject as TBaseSimpleTypeArrayRemotable;
|
|
arrayLen := nativObj.Length;
|
|
styl := GetStyle();
|
|
if ( arrayLen > 0 ) then begin
|
|
AStore.BeginArray(AName,PTypeInfo(Self.ClassInfo),GetItemTypeInfo(),[0,Pred(arrayLen)],styl);
|
|
try
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
for i := 0 to Pred(arrayLen) do begin
|
|
nativObj.SaveItem(AStore,itmName,i);
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end else if ( styl = asScoped ) and ( ioAlwaysSerialize in nativObj.Options ) then begin
|
|
AStore.BeginArray(AName,PTypeInfo(Self.ClassInfo),GetItemTypeInfo(),[0,-1],styl);
|
|
try
|
|
AStore.NilCurrentScope();
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class procedure TBaseSimpleTypeArrayRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
Var
|
|
i, len : Integer;
|
|
nativObj : TBaseSimpleTypeArrayRemotable;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
styl := GetStyle();
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
if (AObject = nil) and Self.InheritsFrom(TBaseArrayRemotable) then
|
|
AObject := Create();
|
|
len := AStore.BeginArrayRead(AName,ATypeInfo, GetStyle(),itmName);
|
|
if ( len > 0 ) then begin
|
|
try
|
|
if not Assigned(AObject) then
|
|
AObject := Create();
|
|
nativObj := AObject as TBaseSimpleTypeArrayRemotable;
|
|
if ( len >= 0 ) then begin
|
|
nativObj.SetLength(len);
|
|
for i := 0 to Pred(len) do begin
|
|
nativObj.LoadItem(AStore,i);
|
|
end;
|
|
end;
|
|
finally
|
|
AStore.EndScopeRead();
|
|
end;
|
|
end else begin
|
|
if ( AObject <> nil ) then
|
|
TBaseSimpleTypeArrayRemotable(AObject).SetLength(0);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfStringRemotable }
|
|
|
|
function TArrayOfStringRemotable.GetItem(AIndex: Integer): String;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfStringRemotable.SetItem(AIndex: Integer;const AValue: String);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfStringRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData)
|
|
end;
|
|
|
|
procedure TArrayOfStringRemotable.SaveItem(
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const AIndex : Integer
|
|
);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(String),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfStringRemotable.LoadItem(
|
|
AStore : IFormatterBase;
|
|
const AIndex : Integer
|
|
);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(String),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfStringRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(String);
|
|
end;
|
|
|
|
procedure TArrayOfStringRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfStringRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfStringRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfStringRemotable) then begin
|
|
src := TArrayOfStringRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
function TArrayOfStringRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
var
|
|
i, c : Integer;
|
|
dst : TArrayOfStringRemotable;
|
|
begin
|
|
if ( Self = ACompareTo ) then begin
|
|
Result := True;
|
|
end else begin
|
|
Result := Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TArrayOfStringRemotable) and
|
|
( Self.Length = TArrayOfStringRemotable(ACompareTo).Length );
|
|
if Result then begin
|
|
c := Self.Length;
|
|
dst := TArrayOfStringRemotable(ACompareTo);
|
|
for i := 0 to Pred(c) do begin
|
|
if ( Self.Item[i] <> dst.Item[i] ) then begin
|
|
Result := False;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TObjectCollectionRemotable }
|
|
|
|
function TObjectCollectionRemotable.GetItem(AIndex : Integer) : TBaseRemotable;
|
|
begin
|
|
Result := TBaseRemotable(FList[AIndex]);
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.GetLength() : Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
class procedure TObjectCollectionRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
Var
|
|
itmTypInfo : PTypeInfo;
|
|
i, arrayLen : Integer;
|
|
nativObj : TObjectCollectionRemotable;
|
|
itm : TObject;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
if Assigned(AObject) then begin
|
|
Assert(AObject.InheritsFrom(TObjectCollectionRemotable));
|
|
nativObj := AObject as TObjectCollectionRemotable;
|
|
styl := GetStyle();
|
|
itmTypInfo := PTypeInfo(GetItemClass().ClassInfo);
|
|
arrayLen := nativObj.Length;
|
|
if ( arrayLen > 0 ) then begin
|
|
AStore.BeginArray(AName,PTypeInfo(Self.ClassInfo),itmTypInfo,[0,Pred(arrayLen)],styl);
|
|
try
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
for i := 0 to Pred(arrayLen) do begin
|
|
itm := nativObj.Item[i];
|
|
AStore.Put(itmName,itmTypInfo,itm);
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end else if ( styl = asScoped ) and ( ioAlwaysSerialize in nativObj.Options ) then begin
|
|
AStore.BeginArray(AName,PTypeInfo(Self.ClassInfo),itmTypInfo,[0,-1],styl);
|
|
try
|
|
AStore.NilCurrentScope();
|
|
finally
|
|
AStore.EndScope();
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
class procedure TObjectCollectionRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
Var
|
|
i, len : Integer;
|
|
nativObj : TObjectCollectionRemotable;
|
|
s : string;
|
|
itmTypInfo : PTypeInfo;
|
|
itm : TBaseRemotable;
|
|
itmName : string;
|
|
styl : TArrayStyle;
|
|
begin
|
|
styl := GetStyle();
|
|
if ( styl = asScoped ) then begin
|
|
itmName := GetItemName();
|
|
end else begin
|
|
itmName := AName;
|
|
end;
|
|
len := AStore.BeginArrayRead(AName,ATypeInfo,styl,itmName);
|
|
if ( len >= 0 ) then begin
|
|
Try
|
|
If Not Assigned(AObject) Then
|
|
AObject := Create();
|
|
itmTypInfo := PTypeInfo(GetItemClass().ClassInfo);
|
|
nativObj := AObject as TObjectCollectionRemotable;
|
|
If ( len > 0 ) Then Begin
|
|
s := '';
|
|
nativObj.Clear();
|
|
For i := 0 To Pred(len) Do Begin
|
|
itm := nativObj.Add();
|
|
AStore.Get(itmTypInfo,s,itm);
|
|
End;
|
|
End;
|
|
Finally
|
|
AStore.EndScopeRead();
|
|
End;
|
|
end else begin
|
|
if ( AObject <> nil ) then
|
|
TObjectCollectionRemotable(AObject).Clear();
|
|
end;
|
|
end;
|
|
|
|
class function TObjectCollectionRemotable.GetItemTypeInfo() : PTypeInfo;
|
|
begin
|
|
Result := PTypeInfo(GetItemClass().ClassInfo);
|
|
end;
|
|
|
|
constructor TObjectCollectionRemotable.Create();
|
|
begin
|
|
inherited Create();
|
|
FList := TObjectList.Create(True);
|
|
end;
|
|
|
|
destructor TObjectCollectionRemotable.Destroy();
|
|
begin
|
|
FreeAndNil(FList);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
procedure TObjectCollectionRemotable.Assign(Source : TPersistent);
|
|
var
|
|
srcCol : TObjectCollectionRemotable;
|
|
src : TBaseObjectArrayRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) then begin
|
|
if Source.InheritsFrom(TObjectCollectionRemotable) then begin
|
|
srcCol := TObjectCollectionRemotable(Source);
|
|
c := srcCol.Length;
|
|
FList.Clear();
|
|
FList.Capacity := c;
|
|
for i := 0 to Pred(c) do begin
|
|
Add().Assign(srcCol.Item[i]);
|
|
end;
|
|
end else if Source.InheritsFrom(TBaseObjectArrayRemotable) then begin
|
|
src := TBaseObjectArrayRemotable(Source);
|
|
c := src.Length;
|
|
FList.Clear();
|
|
FList.Capacity := c;
|
|
for i := 0 to Pred(c) do begin
|
|
Add().Assign(src.Item[i]);
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end else begin
|
|
FList.Clear();
|
|
end;
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
var
|
|
i : Integer;
|
|
nativeCol : TObjectCollectionRemotable;
|
|
nativeArray : TBaseObjectArrayRemotable;
|
|
res : Boolean;
|
|
begin
|
|
res := False;
|
|
if ( ACompareTo <> nil ) then begin
|
|
if ACompareTo.InheritsFrom(TObjectCollectionRemotable) then begin
|
|
nativeCol := TObjectCollectionRemotable(ACompareTo);
|
|
if ( nativeCol.Length = Length ) then begin
|
|
res := True;
|
|
for i := 0 to Pred(Length) do begin
|
|
if not Item[i].Equal(nativeCol[i]) then begin
|
|
res := False;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end else if ACompareTo.InheritsFrom(TBaseObjectArrayRemotable) then begin
|
|
nativeArray := TBaseObjectArrayRemotable(ACompareTo);
|
|
if ( nativeArray.Length = Length ) then begin
|
|
res := True;
|
|
for i := 0 to Pred(Length) do begin
|
|
if not Item[i].Equal(nativeArray[i]) then begin
|
|
res := False;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := res;
|
|
end;
|
|
|
|
procedure TObjectCollectionRemotable.SetLength(const ANewSize: Integer);
|
|
var
|
|
i,oldLen : Integer;
|
|
begin
|
|
if ( FList = nil ) then
|
|
Exit;
|
|
oldLen := FList.Count;
|
|
if ( oldLen = ANewSize ) then
|
|
Exit;
|
|
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidCollectionLength,[ANewSize]);
|
|
|
|
if ( oldLen > ANewSize ) then begin
|
|
for i := ANewSize to Pred(oldLen) do
|
|
FList.Delete(FList.Count - 1);
|
|
end else begin
|
|
if ( FList.Capacity < ANewSize ) then
|
|
FList.Capacity := ANewSize;
|
|
for i := oldLen to Pred(ANewSize) do
|
|
Add();
|
|
end;
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.Add() : TBaseRemotable;
|
|
begin
|
|
Result := GetItemClass().Create();
|
|
try
|
|
FList.Add(Result);
|
|
except
|
|
Result.Free();
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.AddAt(const APosition : Integer) : TBaseRemotable;
|
|
begin
|
|
FList.Insert(APosition,nil);
|
|
try
|
|
Result := GetItemClass().Create();
|
|
except
|
|
FList.Delete(APosition);
|
|
raise;
|
|
end;
|
|
FList[APosition] := Result;
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.Extract(const AIndex : Integer) : TBaseRemotable;
|
|
begin
|
|
Result := TBaseRemotable(FList.Extract(FList[AIndex]));
|
|
end;
|
|
|
|
procedure TObjectCollectionRemotable.Delete(const AIndex : Integer);
|
|
begin
|
|
FList.Delete(AIndex);
|
|
end;
|
|
|
|
procedure TObjectCollectionRemotable.Exchange(const Index1, Index2 : Integer);
|
|
begin
|
|
FList.Exchange(Index1,Index2);
|
|
end;
|
|
|
|
procedure TObjectCollectionRemotable.Clear();
|
|
begin
|
|
FList.Clear();
|
|
end;
|
|
|
|
function TObjectCollectionRemotable.IndexOf(AObject : TBaseRemotable) : Integer;
|
|
begin
|
|
Result := FList.IndexOf(AObject);
|
|
end;
|
|
|
|
{ TBaseArrayRemotable }
|
|
|
|
class function TBaseArrayRemotable.GetItemName(): string;
|
|
var
|
|
tri : TTypeRegistryItem;
|
|
begin
|
|
tri := GetTypeRegistry().Find(PTypeInfo(Self.ClassInfo),False);
|
|
if Assigned(tri) then
|
|
Result := Trim(tri.GetExternalPropertyName(sARRAY_ITEM));
|
|
if ( System.Length(Result) = 0 ) then
|
|
Result := sARRAY_ITEM;
|
|
end;
|
|
|
|
class function TBaseArrayRemotable.GetStyle(): TArrayStyle;
|
|
var
|
|
tri : TTypeRegistryItem;
|
|
begin
|
|
tri := GetTypeRegistry().Find(PTypeInfo(Self.ClassInfo),False);
|
|
if Assigned(tri) and AnsiSameText(sEmbedded,Trim(tri.GetExternalPropertyName(sARRAY_STYLE))) then begin
|
|
Result := asEmbeded;
|
|
end else begin
|
|
Result := asScoped;
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseArrayRemotable.CheckIndex(const AIndex : Integer);
|
|
begin
|
|
if ( AIndex < 0 ) or ( AIndex >= Length ) then
|
|
raise EServiceException.CreateFmt(SERR_IndexOutOfBound,[AIndex]);
|
|
end;
|
|
|
|
destructor TBaseArrayRemotable.Destroy();
|
|
begin
|
|
SetLength(0);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
{ TArrayOfBooleanRemotable }
|
|
|
|
function TArrayOfBooleanRemotable.GetItem(AIndex: Integer): Boolean;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfBooleanRemotable.SetItem(AIndex: Integer;const AValue: Boolean);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfBooleanRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfBooleanRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Boolean),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfBooleanRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Boolean),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfBooleanRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Boolean);
|
|
end;
|
|
|
|
procedure TArrayOfBooleanRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfBooleanRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfBooleanRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfBooleanRemotable) then begin
|
|
src := TArrayOfBooleanRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt8URemotable }
|
|
|
|
function TArrayOfInt8URemotable.GetItem(AIndex: Integer): Byte;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt8URemotable.SetItem(AIndex: Integer; const AValue: Byte);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt8URemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt8URemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Byte),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt8URemotable.LoadItem(AStore: IFormatterBase; const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Byte),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt8URemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Byte);
|
|
end;
|
|
|
|
procedure TArrayOfInt8URemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt8URemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt8URemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt8URemotable) then begin
|
|
src := TArrayOfInt8URemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt8SRemotable }
|
|
|
|
function TArrayOfInt8SRemotable.GetItem(AIndex: Integer): ShortInt;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt8SRemotable.SetItem(AIndex: Integer; const AValue: ShortInt);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt8SRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt8SRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(ShortInt),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt8SRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(ShortInt),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt8SRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(ShortInt);
|
|
end;
|
|
|
|
procedure TArrayOfInt8SRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt8SRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt8SRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt8SRemotable) then begin
|
|
src := TArrayOfInt8SRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt16SRemotable }
|
|
|
|
function TArrayOfInt16SRemotable.GetItem(AIndex: Integer): SmallInt;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt16SRemotable.SetItem(AIndex: Integer;const AValue: SmallInt);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt16SRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt16SRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(SmallInt),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt16SRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(SmallInt),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt16SRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(SmallInt);
|
|
end;
|
|
|
|
procedure TArrayOfInt16SRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt16SRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt16SRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt16SRemotable) then begin
|
|
src := TArrayOfInt16SRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt16URemotable }
|
|
|
|
function TArrayOfInt16URemotable.GetItem(AIndex: Integer): Word;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt16URemotable.SetItem(AIndex: Integer; const AValue: Word);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt16URemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt16URemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Word),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt16URemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Word),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt16URemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Word);
|
|
end;
|
|
|
|
procedure TArrayOfInt16URemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt16URemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt16URemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt16URemotable) then begin
|
|
src := TArrayOfInt16URemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt32URemotable }
|
|
|
|
function TArrayOfInt32URemotable.GetItem(AIndex: Integer): LongWord;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt32URemotable.SetItem(AIndex: Integer;const AValue: LongWord);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt32URemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt32URemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(LongWord),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt32URemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(LongWord),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt32URemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(LongWord);
|
|
end;
|
|
|
|
procedure TArrayOfInt32URemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt32URemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt32URemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt32URemotable) then begin
|
|
src := TArrayOfInt32URemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt32SRemotable }
|
|
|
|
function TArrayOfInt32SRemotable.GetItem(AIndex: Integer): LongInt;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt32SRemotable.SetItem(AIndex: Integer; const AValue: LongInt);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt32SRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt32SRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(LongInt),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt32SRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(LongInt),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt32SRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(LongInt);
|
|
end;
|
|
|
|
procedure TArrayOfInt32SRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt32SRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt32SRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt32SRemotable) then begin
|
|
src := TArrayOfInt32SRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt64SRemotable }
|
|
|
|
function TArrayOfInt64SRemotable.GetItem(AIndex: Integer): Int64;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt64SRemotable.SetItem(AIndex: Integer; const AValue: Int64);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt64SRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt64SRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Int64),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt64SRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Int64),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt64SRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Int64);
|
|
end;
|
|
|
|
procedure TArrayOfInt64SRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt64SRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt64SRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt64SRemotable) then begin
|
|
src := TArrayOfInt64SRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfInt64URemotable }
|
|
|
|
function TArrayOfInt64URemotable.GetItem(AIndex: Integer): QWord;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfInt64URemotable.SetItem(AIndex: Integer; const AValue: QWord);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfInt64URemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfInt64URemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(QWord),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfInt64URemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(QWord),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfInt64URemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(QWord);
|
|
end;
|
|
|
|
procedure TArrayOfInt64URemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfInt64URemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfInt64URemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfInt64URemotable) then begin
|
|
src := TArrayOfInt64URemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfFloatSingleRemotable }
|
|
|
|
function TArrayOfFloatSingleRemotable.GetItem(AIndex: Integer): Single;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfFloatSingleRemotable.SetItem(AIndex: Integer;const AValue: Single);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfFloatSingleRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfFloatSingleRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Single),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfFloatSingleRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Single),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfFloatSingleRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Single);
|
|
end;
|
|
|
|
procedure TArrayOfFloatSingleRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfFloatSingleRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfFloatSingleRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfFloatSingleRemotable) then begin
|
|
src := TArrayOfFloatSingleRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfFloatDoubleRemotable }
|
|
|
|
function TArrayOfFloatDoubleRemotable.GetItem(AIndex: Integer): Double;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfFloatDoubleRemotable.SetItem(AIndex: Integer;const AValue: Double);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfFloatDoubleRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfFloatDoubleRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Double),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfFloatDoubleRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Double),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfFloatDoubleRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Double);
|
|
end;
|
|
|
|
procedure TArrayOfFloatDoubleRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfFloatDoubleRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfFloatDoubleRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfFloatDoubleRemotable) then begin
|
|
src := TArrayOfFloatDoubleRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfFloatExtendedRemotable }
|
|
|
|
function TArrayOfFloatExtendedRemotable.GetItem(AIndex: Integer): Extended;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfFloatExtendedRemotable.SetItem(AIndex: Integer;const AValue: Extended);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfFloatExtendedRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfFloatExtendedRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Extended),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfFloatExtendedRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Extended),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfFloatExtendedRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Extended);
|
|
end;
|
|
|
|
procedure TArrayOfFloatExtendedRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfFloatExtendedRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfFloatExtendedRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfFloatExtendedRemotable) then begin
|
|
src := TArrayOfFloatExtendedRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
{ TArrayOfFloatCurrencyRemotable }
|
|
|
|
function TArrayOfFloatCurrencyRemotable.GetItem(AIndex: Integer): Currency;
|
|
begin
|
|
CheckIndex(AIndex);
|
|
Result := FData[AIndex];
|
|
end;
|
|
|
|
procedure TArrayOfFloatCurrencyRemotable.SetItem(AIndex: Integer;const AValue: Currency);
|
|
begin
|
|
CheckIndex(AIndex);
|
|
FData[AIndex] := AValue;
|
|
end;
|
|
|
|
function TArrayOfFloatCurrencyRemotable.GetLength(): Integer;
|
|
begin
|
|
Result := System.Length(FData);
|
|
end;
|
|
|
|
procedure TArrayOfFloatCurrencyRemotable.SaveItem(AStore: IFormatterBase;
|
|
const AName: String; const AIndex: Integer);
|
|
begin
|
|
AStore.Put(AName,TypeInfo(Currency),FData[AIndex]);
|
|
end;
|
|
|
|
procedure TArrayOfFloatCurrencyRemotable.LoadItem(AStore: IFormatterBase;const AIndex: Integer);
|
|
var
|
|
sName : string;
|
|
begin
|
|
sName := GetItemName();
|
|
AStore.Get(TypeInfo(Currency),sName,FData[AIndex]);
|
|
end;
|
|
|
|
class function TArrayOfFloatCurrencyRemotable.GetItemTypeInfo(): PTypeInfo;
|
|
begin
|
|
Result := TypeInfo(Currency);
|
|
end;
|
|
|
|
procedure TArrayOfFloatCurrencyRemotable.SetLength(const ANewSize: Integer);
|
|
begin
|
|
if ( ANewSize < 0 ) then
|
|
raise EBaseRemoteException.CreateFmt(SERR_InvalidArrayLength,[ANewSize]);
|
|
System.SetLength(FData,ANewSize);
|
|
end;
|
|
|
|
procedure TArrayOfFloatCurrencyRemotable.Assign(Source: TPersistent);
|
|
var
|
|
src : TArrayOfFloatCurrencyRemotable;
|
|
i, c : Integer;
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TArrayOfFloatCurrencyRemotable) then begin
|
|
src := TArrayOfFloatCurrencyRemotable(Source);
|
|
c := src.Length;
|
|
Self.SetLength(c);
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to Pred(c) do begin
|
|
Self[i] := src[i];
|
|
end;
|
|
end;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ THeaderBlock }
|
|
|
|
function THeaderBlock.HasmustUnderstand: boolean;
|
|
begin
|
|
Result := ( FmustUnderstand <> 0 );
|
|
end;
|
|
|
|
function THeaderBlock.GetName : string;
|
|
begin
|
|
if IsStrEmpty(FName) then
|
|
FName := GetExternalName(PTypeInfo(Self.ClassInfo));
|
|
Result := FName;
|
|
end;
|
|
|
|
procedure THeaderBlock.SetmustUnderstand(const AValue: Integer);
|
|
begin
|
|
if ( AValue <> 0 ) then
|
|
FmustUnderstand := 1
|
|
else
|
|
FmustUnderstand := 0;
|
|
end;
|
|
|
|
procedure THeaderBlock.SetName(const AValue: string);
|
|
begin
|
|
FName := AValue;
|
|
end;
|
|
|
|
{ TSimpleContentHeaderBlock }
|
|
|
|
class procedure TSimpleContentHeaderBlock.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
locSerializer : TObjectSerializer;
|
|
locOptionChanged : Boolean;
|
|
begin
|
|
locSerializer := TBaseComplexTypeRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then begin
|
|
locOptionChanged := not ( osoDontDoBeginWrite in locSerializer.Options );
|
|
if locOptionChanged then
|
|
locSerializer.Options := locSerializer.Options + [osoDontDoBeginWrite];
|
|
AStore.BeginObject(AName,ATypeInfo);
|
|
try
|
|
if ( AObject <> nil ) then
|
|
AStore.PutScopeInnerValue(TypeInfo(string),TSimpleContentHeaderBlock(AObject).Value);
|
|
locSerializer.Save(AObject,AStore,AName,ATypeInfo);
|
|
finally
|
|
AStore.EndScope();
|
|
if locOptionChanged then
|
|
locSerializer.Options := locSerializer.Options - [osoDontDoBeginWrite];
|
|
end;
|
|
end else begin
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
end;
|
|
|
|
class procedure TSimpleContentHeaderBlock.Load(
|
|
Var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : String;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
locSerializer : TObjectSerializer;
|
|
locStrBuffer : string;
|
|
begin
|
|
locSerializer := TBaseComplexTypeRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then begin
|
|
if not ( osoDontDoBeginRead in locSerializer.Options ) then
|
|
locSerializer.Options := locSerializer.Options + [osoDontDoBeginRead];
|
|
if ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin
|
|
try
|
|
if AStore.IsCurrentScopeNil() then
|
|
Exit; // ???? FreeAndNil(AObject);
|
|
if not Assigned(AObject) then
|
|
AObject := locSerializer.Target.Create();
|
|
locStrBuffer := '';
|
|
AStore.GetScopeInnerValue(TypeInfo(string),locStrBuffer);
|
|
TSimpleContentHeaderBlock(AObject).Value := locStrBuffer;
|
|
locSerializer.Read(AObject,AStore,AName,ATypeInfo);
|
|
finally
|
|
AStore.EndScopeRead();
|
|
end;
|
|
end;
|
|
end else begin
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
end;
|
|
|
|
{ THeaderBlockProxy }
|
|
|
|
procedure THeaderBlockProxy.SetActualObject(const AValue: TBaseRemotable);
|
|
var
|
|
locObj : TObject;
|
|
begin
|
|
if ( FActualObject <> AValue ) then begin
|
|
if OwnObject and ( FActualObject <> nil ) then begin
|
|
locObj := FActualObject;
|
|
FActualObject := nil;
|
|
locObj.Free();
|
|
end;
|
|
FActualObject := AValue;
|
|
end;
|
|
end;
|
|
|
|
function THeaderBlockProxy.GetName : string;
|
|
begin
|
|
if FNameSet then
|
|
Result := inherited GetName()
|
|
else if ( ActualObject <> nil ) then
|
|
Result := GetExternalName(PTypeInfo(ActualObject.ClassInfo))
|
|
else
|
|
Result := Self.ClassName();
|
|
end;
|
|
|
|
procedure THeaderBlockProxy.SetName(const AValue: string);
|
|
begin
|
|
inherited SetName(AValue);
|
|
FNameSet := not IsStrEmpty(AValue);
|
|
end;
|
|
|
|
procedure THeaderBlockProxy.FreeObjectProperties();
|
|
begin
|
|
if OwnObject then
|
|
FreeAndNil(FActualObject);
|
|
inherited FreeObjectProperties();
|
|
end;
|
|
|
|
class procedure THeaderBlockProxy.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
locObj : THeaderBlockProxy;
|
|
begin
|
|
if ( AObject <> nil ) and AObject.InheritsFrom(THeaderBlockProxy) then begin
|
|
locObj := THeaderBlockProxy(AObject);
|
|
if ( locObj.ActualObject <> nil ) then
|
|
locObj.ActualObject.Save(
|
|
locObj.ActualObject,
|
|
AStore,
|
|
AName,
|
|
PTypeInfo(locObj.ActualObject.ClassInfo)
|
|
);
|
|
end;
|
|
end;
|
|
|
|
class procedure THeaderBlockProxy.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
locObj : THeaderBlockProxy;
|
|
locActualObj : TObject;
|
|
begin
|
|
if ( AObject <> nil ) and AObject.InheritsFrom(THeaderBlockProxy) then begin
|
|
locObj := THeaderBlockProxy(AObject);
|
|
if ( locObj.ActualObject <> nil ) then
|
|
locActualObj := locObj.ActualObject;
|
|
locObj.ActualObject.Load(
|
|
locActualObj,
|
|
AStore,
|
|
AName,
|
|
PTypeInfo(locObj.ActualObject.ClassInfo)
|
|
);
|
|
if ( locObj.ActualObject <> locActualObj ) then
|
|
locObj.ActualObject := TBaseRemotable(locActualObj);
|
|
end;
|
|
end;
|
|
|
|
{ TStoredPropertyManager }
|
|
|
|
procedure TStoredPropertyManager.Error(Const AMsg: string);
|
|
begin
|
|
raise EPropertyException.Create(AMsg);
|
|
end;
|
|
|
|
procedure TStoredPropertyManager.Error(
|
|
Const AMsg: string;
|
|
Const AArgs: array of const
|
|
);
|
|
begin
|
|
raise EPropertyException.CreateFmt(AMsg,AArgs);
|
|
end;
|
|
|
|
procedure TStoredPropertyManager.SetProperty(Const AName, AValue: string);
|
|
begin
|
|
FData.Values[AName] := AValue;
|
|
end;
|
|
|
|
procedure TStoredPropertyManager.SetProperties(Const APropsStr: string);
|
|
var
|
|
lst : TStringList;
|
|
i : Integer;
|
|
begin
|
|
if ( Length(Trim(APropsStr)) = 0 ) then
|
|
Exit;
|
|
lst := TStringList.Create();
|
|
try
|
|
lst.QuoteChar := #0;
|
|
lst.Delimiter := PROP_LIST_DELIMITER;
|
|
lst.DelimitedText := APropsStr;
|
|
for i := 0 to Pred(lst.Count) do
|
|
SetProperty(lst.Names[i],lst.Values[lst.Names[i]]);
|
|
finally
|
|
lst.Free();
|
|
end;
|
|
end;
|
|
|
|
function TStoredPropertyManager.GetProperty(Const AName: String): string;
|
|
begin
|
|
Result := FData.Values[AName];
|
|
end;
|
|
|
|
function TStoredPropertyManager.GetPropertyNames(ADest: TStrings): Integer;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
ADest.Clear();
|
|
Result := FData.Count;
|
|
for i := 0 to Pred(Result) do
|
|
ADest.Add(FData.Names[i]);
|
|
end;
|
|
|
|
procedure TStoredPropertyManager.Clear();
|
|
begin
|
|
FData.Clear();
|
|
end;
|
|
|
|
procedure TStoredPropertyManager.Copy(
|
|
ASource : IPropertyManager;
|
|
Const AClearBefore : Boolean
|
|
);
|
|
var
|
|
lst : TStringList;
|
|
i : Integer;
|
|
s : string;
|
|
begin
|
|
if AClearBefore then
|
|
Clear();
|
|
if Assigned(ASource) then begin
|
|
lst := TStringList.Create();
|
|
try
|
|
ASource.GetPropertyNames(lst);
|
|
for i := 0 to Pred(lst.Count) do begin
|
|
s := lst[i];
|
|
SetProperty(s,ASource.GetProperty(s));
|
|
end;
|
|
finally
|
|
lst.Free();
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
constructor TStoredPropertyManager.Create();
|
|
begin
|
|
FData := TStringList.Create();
|
|
end;
|
|
|
|
destructor TStoredPropertyManager.Destroy();
|
|
begin
|
|
FreeAndNil(FData);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
|
|
{ TAbstractComplexRemotable }
|
|
|
|
class procedure TAbstractComplexRemotable.RegisterAttributeProperty(const AProperty: shortstring);
|
|
var
|
|
ri : TSerializeOptions;
|
|
begin
|
|
ri := GetSerializeOptionsRegistry().Find(Self);
|
|
if not Assigned(ri) then
|
|
ri := GetSerializeOptionsRegistry().RegisterClass(Self);
|
|
ri.AddAttributeField(AProperty);
|
|
end;
|
|
|
|
class procedure TAbstractComplexRemotable.RegisterAttributeProperties(const APropertList: array of shortstring);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := Low(APropertList) to High(APropertList) do
|
|
RegisterAttributeProperty(APropertList[i]);
|
|
end;
|
|
|
|
class function TAbstractComplexRemotable.IsAttributeProperty(const AProperty: shortstring): Boolean;
|
|
var
|
|
ri : TSerializeOptions;
|
|
pc : TClass;
|
|
sor : TSerializeOptionsRegistry;
|
|
begin
|
|
Result := False;
|
|
if ( Self = TBaseComplexRemotable ) then
|
|
Exit;
|
|
sor := GetSerializeOptionsRegistry();
|
|
pc := Self;
|
|
while Assigned(pc) and pc.InheritsFrom(TBaseComplexRemotable) do begin
|
|
ri := sor.Find(TBaseComplexRemotableClass(pc));
|
|
if Assigned(ri) then begin
|
|
Result := ri.IsAttributeField(AProperty);
|
|
Exit;
|
|
end;
|
|
pc := pc.ClassParent;
|
|
end;
|
|
end;
|
|
|
|
procedure TAbstractComplexRemotable.Assign(Source: TPersistent);
|
|
var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
p, sp : PPropInfo;
|
|
selfTypeInfo : PTypeInfo;
|
|
srcObj, dstObj : TObject;
|
|
begin
|
|
if not Assigned(Source) then
|
|
Exit;
|
|
selfTypeInfo := Self.ClassInfo;
|
|
propCount := GetTypeData(selfTypeInfo)^.PropCount;
|
|
if ( propCount > 0 ) then begin
|
|
propListLen := GetPropList(selfTypeInfo,propList);
|
|
try
|
|
for i := 0 to Pred(propCount) do begin
|
|
p := propList^[i];
|
|
sp := GetPropInfo(Source,p^.Name);
|
|
if Assigned(sp) and Assigned(sp^.GetProc) and
|
|
((p^.PropType^.Kind = tkClass) or Assigned(p^.SetProc))
|
|
then begin
|
|
case p^.PropType^.Kind of
|
|
tkInt64{$IFDEF HAS_QWORD} ,tkQWord{$ENDIF} :
|
|
SetInt64Prop(Self,p,GetInt64Prop(Source,p^.Name));
|
|
{$IFDEF HAS_TKBOOL}tkBool,{$ENDIF} tkEnumeration, tkInteger :
|
|
SetOrdProp(Self,p,GetOrdProp(Source,p^.Name));
|
|
tkLString{$IFDEF FPC}, tkAString{$ENDIF} :
|
|
SetStrProp(Self,p,GetStrProp(Source,p^.Name));
|
|
{$IFDEF WST_UNICODESTRING}
|
|
tkUString :
|
|
SetUnicodeStrProp(Self,p,GetUnicodeStrProp(Source,p^.Name));
|
|
{$ENDIF WST_UNICODESTRING}
|
|
tkClass :
|
|
begin
|
|
srcObj := GetObjectProp(Source,p^.Name);
|
|
dstObj := GetObjectProp(Self,p^.Name);
|
|
if (dstObj <> nil) then begin
|
|
if ( not Assigned(dstObj) ) and
|
|
( Assigned(srcObj) and srcObj.InheritsFrom(TAbstractComplexRemotable) )
|
|
then begin
|
|
dstObj := TAbstractComplexRemotableClass(srcObj.ClassType).Create();
|
|
SetObjectProp(Self,p,dstObj);
|
|
end;
|
|
if Assigned(dstObj) then begin
|
|
if ( srcObj = nil ) then begin
|
|
FreeAndNil(dstObj);
|
|
SetObjectProp(Self,p,dstObj);
|
|
end else begin
|
|
if dstObj.InheritsFrom(TPersistent) and srcObj.InheritsFrom(TPersistent) then
|
|
TPersistent(dstObj).Assign(TPersistent(srcObj));
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
tkFloat :
|
|
SetFloatProp(Self,p,GetFloatProp(Source,p^.Name));
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TAbstractComplexRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
p, sp : PPropInfo;
|
|
selfTypeInfo : PTypeInfo;
|
|
srcObj, dstObj : TObject;
|
|
ok : Boolean;
|
|
currencyA, currencyB : record
|
|
case Integer of
|
|
0 : (CurrencyValue : Currency;);
|
|
1 : (Int64Value : Int64;);
|
|
end;
|
|
begin
|
|
Result := False;
|
|
if not Assigned(ACompareTo) then
|
|
Exit;
|
|
if not ACompareTo.InheritsFrom(Self.ClassType) then
|
|
Exit;
|
|
|
|
ok := True;
|
|
selfTypeInfo := Self.ClassInfo;
|
|
propCount := GetTypeData(selfTypeInfo)^.PropCount;
|
|
if ( propCount > 0 ) then begin
|
|
propListLen := GetPropList(selfTypeInfo,propList);
|
|
try
|
|
for i := 0 to Pred(propCount) do begin
|
|
p := propList^[i];
|
|
sp := GetPropInfo(Self,p^.Name);
|
|
if Assigned(sp) and Assigned(sp^.GetProc) then begin
|
|
case p^.PropType^.Kind of
|
|
tkInt64{$IFDEF HAS_QWORD} ,tkQWord{$ENDIF} :
|
|
ok := ( GetInt64Prop(Self,p^.Name) = GetInt64Prop(ACompareTo,p^.Name) );
|
|
{$IFDEF HAS_TKBOOL}tkBool,{$ENDIF} tkEnumeration, tkInteger :
|
|
ok := ( GetOrdProp(Self,p^.Name) = GetOrdProp(ACompareTo,p^.Name) );
|
|
{$IFDEF FPC}
|
|
tkAString,
|
|
{$ENDIF FPC}
|
|
{$IFDEF WST_UNICODESTRING}
|
|
tkUString,
|
|
{$ENDIF WST_UNICODESTRING}
|
|
tkLString :
|
|
ok := ( GetStrProp(Self,p^.Name) = GetStrProp(ACompareTo,p^.Name) );
|
|
tkClass :
|
|
begin
|
|
if GetTypeData(p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF})^.ClassType.InheritsFrom(TBaseRemotable) then begin
|
|
srcObj := GetObjectProp(Self,p^.Name);
|
|
dstObj := GetObjectProp(ACompareTo,p^.Name);
|
|
ok := ( Assigned(srcObj) and TBaseRemotable(srcObj).Equal(TBaseRemotable(dstObj)) ) or
|
|
( ( srcObj = nil ) and ( dstObj = nil ) ) ;
|
|
end;
|
|
end;
|
|
tkFloat :
|
|
begin
|
|
case GetTypeData(p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF})^.FloatType of
|
|
ftSingle, ftDouble, ftExtended :
|
|
ok := (GetFloatProp(Self,p^.Name) = GetFloatProp(ACompareTo,p^.Name));
|
|
ftCurr :
|
|
begin
|
|
currencyA.CurrencyValue := GetFloatProp(Self,p^.Name);
|
|
currencyB.CurrencyValue := GetFloatProp(ACompareTo,p^.Name);
|
|
ok := (currencyA.Int64Value = currencyB.Int64Value);
|
|
end;
|
|
else
|
|
ok := (GetFloatProp(Self,p^.Name) = GetFloatProp(ACompareTo,p^.Name));
|
|
end;
|
|
end;
|
|
end;
|
|
if not ok then
|
|
Break;
|
|
end;
|
|
end;
|
|
finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
Result := ok;
|
|
end;
|
|
|
|
{ TBaseComplexSimpleContentRemotable }
|
|
|
|
class procedure TBaseComplexSimpleContentRemotable.Save(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase;
|
|
const AName: string;
|
|
const ATypeInfo: PTypeInfo
|
|
);
|
|
{$IFDEF USE_SERIALIZE}
|
|
var
|
|
locSerializer : TSimpleContentObjectSerializer;
|
|
begin
|
|
locSerializer := TSimpleContentObjectRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then
|
|
locSerializer.Save(AObject,AStore,AName,ATypeInfo)
|
|
else
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
{$ELSE USE_SERIALIZE}
|
|
Var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
pt : PTypeInfo;
|
|
int64Data : Int64;
|
|
strData : String;
|
|
objData : TObject;
|
|
boolData : Boolean;
|
|
enumData : TEnumBuffer;
|
|
floatDt : TFloatBuffer;
|
|
p : PPropInfo;
|
|
oldSS : TSerializationStyle;
|
|
tr : TTypeRegistry;
|
|
regItem : TTypeRegistryItem;
|
|
propName : string;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
AStore.BeginObject(AName,ATypeInfo);
|
|
try
|
|
if not Assigned(AObject) then begin
|
|
AStore.NilCurrentScope();
|
|
Exit;
|
|
end;
|
|
SaveValue(AObject,AStore);
|
|
propCount := GetTypeData(ATypeInfo)^.PropCount;
|
|
if ( propCount > 0 ) then begin
|
|
propListLen := GetPropList(ATypeInfo,propList);
|
|
try
|
|
tr := GetTypeRegistry();
|
|
regItem := tr.ItemByTypeInfo[ATypeInfo];
|
|
AStore.SetSerializationStyle(ssAttibuteSerialization);
|
|
for i := 0 to Pred(propCount) do begin
|
|
p := propList^[i];
|
|
pt := p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF};
|
|
propName := regItem.GetExternalPropertyName(p^.Name);
|
|
if IsStoredProp(AObject,p) then begin
|
|
case pt^.Kind of
|
|
tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} :
|
|
begin
|
|
int64Data := GetOrdProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,int64Data);
|
|
end;
|
|
tkLString
|
|
{$IFDEF FPC},tkAString{$ENDIF}
|
|
{$IFDEF WST_UNICODESTRING}, tkUString{$ENDIF}:
|
|
begin
|
|
strData := GetStrProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,strData);
|
|
end;
|
|
tkClass :
|
|
begin
|
|
objData := GetObjectProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,objData);
|
|
end;
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool :
|
|
begin
|
|
boolData := Boolean(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,boolData);
|
|
end;
|
|
{$ENDIF}
|
|
tkEnumeration,tkInteger :
|
|
begin
|
|
{$IFDEF WST_DELPHI}
|
|
if ( pt^.Kind = tkEnumeration ) and
|
|
( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
boolData := Boolean(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,boolData);
|
|
end else begin
|
|
{$ENDIF}
|
|
FillChar(enumData,SizeOf(enumData),#0);
|
|
case GetTypeData(pt)^.OrdType of
|
|
otSByte :
|
|
begin
|
|
enumData.ShortIntData := ShortInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.ShortIntData);
|
|
end;
|
|
otUByte :
|
|
begin
|
|
enumData.ByteData := Byte(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.ByteData);
|
|
end;
|
|
otSWord :
|
|
begin
|
|
enumData.SmallIntData := SmallInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.SmallIntData);
|
|
end;
|
|
otUWord :
|
|
begin
|
|
enumData.WordData := Word(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.WordData);
|
|
end;
|
|
otSLong :
|
|
begin
|
|
enumData.SLongIntData := LongInt(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.SLongIntData);
|
|
end;
|
|
otULong :
|
|
begin
|
|
enumData.ULongIntData := LongWord(GetOrdProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,enumData.ULongIntData);
|
|
end;
|
|
end;
|
|
{$IFDEF WST_DELPHI}
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
tkFloat :
|
|
begin
|
|
FillChar(floatDt,SizeOf(floatDt),#0);
|
|
case GetTypeData(pt)^.FloatType of
|
|
ftSingle :
|
|
begin
|
|
floatDt.SingleData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,floatDt.SingleData);
|
|
end;
|
|
ftDouble :
|
|
begin
|
|
floatDt.DoubleData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,floatDt.DoubleData);
|
|
end;
|
|
ftExtended :
|
|
begin
|
|
floatDt.ExtendedData := Extended(GetFloatProp(AObject,p^.Name));
|
|
AStore.Put(propName,pt,floatDt.ExtendedData);
|
|
end;
|
|
ftCurr :
|
|
begin
|
|
floatDt.CurrencyData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,floatDt.CurrencyData);
|
|
end;
|
|
{$IFDEF HAS_COMP}
|
|
ftComp :
|
|
begin
|
|
floatDt.CompData := GetFloatProp(AObject,p^.Name);
|
|
AStore.Put(propName,pt,floatDt.CompData);
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
end;
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
{$ENDIF USE_SERIALIZE}
|
|
|
|
class procedure TBaseComplexSimpleContentRemotable.Load(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase;
|
|
var AName: string;
|
|
const ATypeInfo: PTypeInfo
|
|
);
|
|
{$IFDEF USE_SERIALIZE}
|
|
var
|
|
locSerializer : TSimpleContentObjectSerializer;
|
|
begin
|
|
locSerializer := TSimpleContentObjectRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
|
|
if ( locSerializer <> nil ) then
|
|
locSerializer.Read(AObject,AStore,AName,ATypeInfo)
|
|
else
|
|
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
|
|
end;
|
|
{$ELSE USE_SERIALIZE}
|
|
Var
|
|
propList : PPropList;
|
|
i, propCount, propListLen : Integer;
|
|
pt : PTypeInfo;
|
|
propName : String;
|
|
int64Data : Int64;
|
|
strData : String;
|
|
objData : TObject;
|
|
objDataCreateHere : Boolean;
|
|
{$IFDEF HAS_TKBOOL}boolData : Boolean;{$ENDIF}
|
|
p : PPropInfo;
|
|
enumData : TEnumBuffer;
|
|
floatDt : TFloatExtendedType;
|
|
floatBuffer : TFloatBuffer;
|
|
persistType : TPropStoreType;
|
|
objTypeData : PTypeData;
|
|
oldSS : TSerializationStyle;
|
|
tr : TTypeRegistry;
|
|
regItem : TTypeRegistryItem;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
if ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin
|
|
try
|
|
if AStore.IsCurrentScopeNil() then
|
|
Exit; // ???? FreeAndNil(AObject);
|
|
If Not Assigned(AObject) Then
|
|
AObject := Create();
|
|
LoadValue(AObject,AStore);
|
|
objTypeData := GetTypeData(ATypeInfo);
|
|
propCount := objTypeData^.PropCount;
|
|
If ( propCount > 0 ) Then Begin
|
|
propListLen := GetPropList(ATypeInfo,propList);
|
|
Try
|
|
tr := GetTypeRegistry();
|
|
regItem := tr.ItemByTypeInfo[ATypeInfo];
|
|
AStore.SetSerializationStyle(ssAttibuteSerialization);
|
|
For i := 0 To Pred(propCount) Do Begin
|
|
p := propList^[i];
|
|
persistType := IsStoredPropClass(objTypeData^.ClassType,p);
|
|
If ( persistType in [pstOptional,pstAlways] ) Then Begin
|
|
pt := p^.PropType{$IFDEF WST_DELPHI}^{$ENDIF};
|
|
propName := regItem.GetExternalPropertyName(p^.Name);
|
|
try
|
|
Case pt^.Kind Of
|
|
tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} :
|
|
Begin
|
|
AStore.Get(pt,propName,int64Data);
|
|
SetOrdProp(AObject,p^.Name,int64Data);
|
|
End;
|
|
tkLString
|
|
{$IFDEF FPC},tkAString{$ENDIF}
|
|
{$IFDEF WST_UNICODESTRING}, tkUString{$ENDIF}:
|
|
Begin
|
|
AStore.Get(pt,propName,strData);
|
|
SetStrProp(AObject,p^.Name,strData);
|
|
End;
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool :
|
|
Begin
|
|
AStore.Get(pt,propName,boolData);
|
|
SetOrdProp(AObject,p^.Name,Ord(boolData));
|
|
End;
|
|
{$ENDIF}
|
|
tkClass :
|
|
Begin
|
|
objData := GetObjectProp(AObject,p^.Name);
|
|
objDataCreateHere := not Assigned(objData);
|
|
try
|
|
AStore.Get(pt,propName,objData);
|
|
if objDataCreateHere then
|
|
SetObjectProp(AObject,p^.Name,objData);
|
|
finally
|
|
if objDataCreateHere then
|
|
FreeAndNil(objData);
|
|
end;
|
|
End;
|
|
tkEnumeration,tkInteger :
|
|
Begin
|
|
FillChar(enumData,SizeOf(enumData),#0);
|
|
Case GetTypeData(pt)^.OrdType Of
|
|
otSByte :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ShortIntData);
|
|
int64Data := enumData.ShortIntData;
|
|
End;
|
|
otUByte :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ByteData);
|
|
int64Data := enumData.ByteData;
|
|
End;
|
|
otSWord :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.SmallIntData);
|
|
int64Data := enumData.SmallIntData;
|
|
End;
|
|
otUWord :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.WordData);
|
|
int64Data := enumData.WordData;
|
|
End;
|
|
otSLong:
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.SLongIntData);
|
|
int64Data := enumData.SLongIntData;
|
|
End;
|
|
otULong :
|
|
Begin
|
|
AStore.Get(pt,propName,enumData.ULongIntData);
|
|
int64Data := enumData.ULongIntData;
|
|
End;
|
|
End;
|
|
SetOrdProp(AObject,p^.Name,int64Data);
|
|
End;
|
|
tkFloat :
|
|
Begin
|
|
FillChar(floatDt,SizeOf(floatBuffer),#0);
|
|
Case GetTypeData(pt)^.FloatType Of
|
|
ftSingle :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.SingleData);
|
|
floatDt := floatBuffer.SingleData;
|
|
End;
|
|
ftDouble :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.DoubleData);
|
|
floatDt := floatBuffer.DoubleData;
|
|
End;
|
|
ftExtended :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.ExtendedData);
|
|
floatDt := floatBuffer.ExtendedData;
|
|
End;
|
|
ftCurr :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.CurrencyData);
|
|
floatDt := floatBuffer.CurrencyData;
|
|
End;
|
|
ftComp :
|
|
Begin
|
|
AStore.Get(pt,propName,floatBuffer.CompData);
|
|
floatDt := floatBuffer.CompData;
|
|
End;
|
|
End;
|
|
SetFloatProp(AObject,p^.Name,floatDt);
|
|
End;
|
|
End;
|
|
except
|
|
on E : EServiceException do begin
|
|
if ( persistType = pstAlways ) then
|
|
raise;
|
|
end;
|
|
end;
|
|
End;
|
|
End;
|
|
Finally
|
|
Freemem(propList,propListLen*SizeOf(Pointer));
|
|
End;
|
|
End;
|
|
finally
|
|
AStore.EndScopeRead();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF USE_SERIALIZE}
|
|
|
|
{ TComplexEnumContentRemotable }
|
|
|
|
class procedure TComplexEnumContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(GetEnumTypeInfo(),(AObject as TComplexEnumContentRemotable).GetValueAddress()^);
|
|
end;
|
|
|
|
class procedure TComplexEnumContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
locObject : TComplexEnumContentRemotable;
|
|
locBuffer : Pointer;
|
|
begin
|
|
locObject := AObject as TComplexEnumContentRemotable;
|
|
locBuffer := locObject.GetValueAddress();
|
|
AStore.GetScopeInnerValue(GetEnumTypeInfo(),locBuffer^);
|
|
end;
|
|
|
|
{ TComplexInt32SContentRemotable }
|
|
|
|
class procedure TComplexInt32SContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(LongInt),(AObject as TComplexInt32SContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt32SContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : LongInt;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(LongInt),i);
|
|
(AObject as TComplexInt32SContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt32SContentRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt32UContentRemotable }
|
|
|
|
class procedure TComplexInt32UContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(LongWord),(AObject as TComplexInt32UContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt32UContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : LongWord;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(LongWord),i);
|
|
(AObject as TComplexInt32UContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt32UContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt16SContentRemotable }
|
|
|
|
class procedure TComplexInt16SContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(SmallInt),(AObject as TComplexInt16SContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt16SContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : SmallInt;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(SmallInt),i);
|
|
(AObject as TComplexInt16SContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt16SContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt16UContentRemotable }
|
|
|
|
class procedure TComplexInt16UContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Word),(AObject as TComplexInt16UContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt16UContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Word;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Word),i);
|
|
(AObject as TComplexInt16UContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt16UContentRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexFloatExtendedContentRemotable }
|
|
|
|
class procedure TComplexFloatExtendedContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Extended),(AObject as TComplexFloatExtendedContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexFloatExtendedContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Extended;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Extended),i);
|
|
(AObject as TComplexFloatExtendedContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexFloatExtendedContentRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexFloatDoubleContentRemotable }
|
|
|
|
class procedure TComplexFloatDoubleContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Double),(AObject as TComplexFloatDoubleContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexFloatDoubleContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Double;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Double),i);
|
|
(AObject as TComplexFloatDoubleContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexFloatDoubleContentRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexStringContentRemotable }
|
|
|
|
class procedure TComplexStringContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(string),(AObject as TComplexStringContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexStringContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : string;
|
|
begin
|
|
i := '';
|
|
AStore.GetScopeInnerValue(TypeInfo(string),i);
|
|
(AObject as TComplexStringContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexStringContentRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (FValue <> '');
|
|
end;
|
|
|
|
{ TComplexWideStringContentRemotable }
|
|
|
|
class procedure TComplexWideStringContentRemotable.SaveValue(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(WideString),(AObject as TComplexWideStringContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexWideStringContentRemotable.LoadValue(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
i : WideString;
|
|
begin
|
|
i := '';
|
|
AStore.GetScopeInnerValue(TypeInfo(WideString),i);
|
|
(AObject as TComplexWideStringContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexWideStringContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> '');
|
|
end;
|
|
|
|
{$IFDEF WST_UNICODESTRING}
|
|
{ TComplexUnicodeStringContentRemotable }
|
|
|
|
class procedure TComplexUnicodeStringContentRemotable.SaveValue(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(UnicodeString),(AObject as TComplexUnicodeStringContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexUnicodeStringContentRemotable.LoadValue(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
i : UnicodeString;
|
|
begin
|
|
i := '';
|
|
AStore.GetScopeInnerValue(TypeInfo(UnicodeString),i);
|
|
(AObject as TComplexUnicodeStringContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexUnicodeStringContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> '');
|
|
end;
|
|
{$ENDIF WST_UNICODESTRING}
|
|
|
|
{ TDateRemotable }
|
|
|
|
class function TDateRemotable.ToStr(const ADate : TDateTimeRec) : string;
|
|
begin
|
|
Result := xsd_DateTimeToStr(ADate,xdkDate);
|
|
end;
|
|
|
|
class function TDateRemotable.Parse(const ABuffer : string) : TDateTimeRec;
|
|
begin
|
|
Result := xsd_StrToDate(ABuffer,xdkDate);
|
|
end;
|
|
|
|
{ TDateTimeRemotable }
|
|
|
|
class function TDateTimeRemotable.ToStr(const ADate: TDateTimeRec): string;
|
|
begin
|
|
Result := xsd_DateTimeToStr(ADate,xdkDateTime);
|
|
end;
|
|
|
|
class function TDateTimeRemotable.Parse(const ABuffer: string): TDateTimeRec;
|
|
begin
|
|
Result := xsd_StrToDate(ABuffer,xdkDateTime);
|
|
end;
|
|
|
|
function TDateTimeRemotable.GetDatepart(const AIndex: Integer): Integer;
|
|
begin
|
|
case AIndex of
|
|
3 : Result := HourOf(AsDate);
|
|
4 : Result := MinuteOf(AsDate);
|
|
5 : Result := SecondOf(AsDate);
|
|
else
|
|
Result := inherited GetDatepart(AIndex);
|
|
end;
|
|
end;
|
|
|
|
{ TBaseDateRemotable }
|
|
|
|
procedure TBaseDateRemotable.SetDate(const AIndex : Integer; const AValue: TDateTime);
|
|
begin
|
|
FDate.Date := AValue;
|
|
if ( AIndex = 1 ) then begin
|
|
if ( FDate.HourOffset <> 0 ) then
|
|
FDate.Date := date_utils.IncHour(FDate.Date,FDate.HourOffset);
|
|
if ( FDate.MinuteOffset <> 0 ) then
|
|
FDate.Date := IncMinute(FDate.Date,FDate.MinuteOffset);
|
|
end;
|
|
end;
|
|
|
|
class procedure TBaseDateRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := TBaseDateRemotable(AObject).AsString;
|
|
AStore.Put(AName,TypeInfo(string),buffer);
|
|
end;
|
|
|
|
class procedure TBaseDateRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := '';
|
|
AStore.Get(TypeInfo(string),AName,buffer);
|
|
if ( AObject = nil ) then
|
|
AObject := Create();
|
|
TBaseDateRemotable(AObject).AsString := buffer;
|
|
end;
|
|
|
|
procedure TBaseDateRemotable.Assign(Source: TPersistent);
|
|
begin
|
|
if Source.InheritsFrom(TBaseDateRemotable) then begin
|
|
FDate := TBaseDateRemotable(Source).FDate;
|
|
end else begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
function TBaseDateRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
begin
|
|
Result := ( Self = ACompareTo ) or
|
|
( Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TBaseDateRemotable) and
|
|
( Self.AsDate = TBaseDateRemotable(ACompareTo).AsDate )
|
|
);
|
|
end;
|
|
|
|
function TBaseDateRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FDate.Date <> 0);
|
|
end;
|
|
|
|
function TBaseDateRemotable.GetDate(const AIndex : Integer) : TDateTime;
|
|
begin
|
|
Result := FDate.Date;
|
|
if ( AIndex = 1 ) then begin
|
|
if ( FDate.HourOffset <> 0 ) then
|
|
Result := date_utils.IncHour(Result,-FDate.HourOffset);
|
|
if ( FDate.MinuteOffset <> 0 ) then
|
|
Result := date_utils.IncMinute(Result,-FDate.MinuteOffset);
|
|
end;
|
|
end;
|
|
|
|
function TBaseDateRemotable.GetDatepart(const AIndex: Integer): Integer;
|
|
begin
|
|
case AIndex of
|
|
0 : Result := YearOf(AsDate);
|
|
1 : Result := MonthOf(AsDate);
|
|
2 : Result := DayOf(AsDate);
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TBaseDateRemotable.GetAsString: string;
|
|
begin
|
|
Result := ToStr(FDate);
|
|
end;
|
|
|
|
function TBaseDateRemotable.GetOffset(const Index: Integer): Shortint;
|
|
begin
|
|
if ( Index = 0 ) then
|
|
Result := FDate.HourOffset
|
|
else
|
|
Result := FDate.MinuteOffset;
|
|
end;
|
|
|
|
procedure TBaseDateRemotable.SetAsString(const AValue: string);
|
|
begin
|
|
if (AValue<>'') then
|
|
FDate := Parse(AValue)
|
|
else
|
|
FillChar(FDate,SizeOf(TDateTimeRec),0);
|
|
end;
|
|
|
|
procedure TBaseDateRemotable.SetOffset(const Index: Integer; const Value: Shortint);
|
|
begin
|
|
if ( Index = 0 ) then begin
|
|
if ( Value >= -14 ) and ( Value <= 14 ) then
|
|
FDate.HourOffset := Value
|
|
else
|
|
raise Exception.CreateFmt(SERR_InvalidHourOffetValue,[Value]);
|
|
end else begin
|
|
if ( Value >= -59 ) and ( Value <= 59 ) then
|
|
FDate.MinuteOffset := Value
|
|
else
|
|
raise Exception.CreateFmt(SERR_InvalidMinuteOffetValue,[Value]);
|
|
end;
|
|
end;
|
|
|
|
class function TBaseDateRemotable.ToStr(const ADate: TDateTime): string;
|
|
var
|
|
locTemp : TDateTimeRec;
|
|
begin
|
|
locTemp.Date := ADate;
|
|
locTemp.HourOffset := 0;
|
|
locTemp.MinuteOffset := 0;
|
|
Result := ToStr(locTemp);
|
|
end;
|
|
|
|
class function TBaseDateRemotable.ParseToUTC(const ABuffer : string) : TDateTime;
|
|
begin
|
|
Result := NormalizeToUTC(Parse(ABuffer));
|
|
end;
|
|
|
|
{ TComplexInt8SContentRemotable }
|
|
|
|
class procedure TComplexInt8SContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(ShortInt),(AObject as TComplexInt8SContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt8SContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : ShortInt;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(ShortInt),i);
|
|
(AObject as TComplexInt8SContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt8SContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt8UContentRemotable }
|
|
|
|
class procedure TComplexInt8UContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Byte),(AObject as TComplexInt8UContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt8UContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Byte;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Byte),i);
|
|
(AObject as TComplexInt8UContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt8UContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexFloatSingleContentRemotable }
|
|
|
|
class procedure TComplexFloatSingleContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Single),(AObject as TComplexFloatSingleContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexFloatSingleContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Single;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Single),i);
|
|
(AObject as TComplexFloatSingleContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexFloatSingleContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexCurrencyContentRemotable }
|
|
|
|
class procedure TComplexCurrencyContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Currency),(AObject as TComplexCurrencyContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexCurrencyContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Currency;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Currency),i);
|
|
(AObject as TComplexCurrencyContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexCurrencyContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt64SContentRemotable }
|
|
|
|
class procedure TComplexInt64SContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Int64),(AObject as TComplexInt64SContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt64SContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Int64;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(Int64),i);
|
|
(AObject as TComplexInt64SContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt64SContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexInt64UContentRemotable }
|
|
|
|
class procedure TComplexInt64UContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(QWord),(AObject as TComplexInt64UContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexInt64UContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : QWord;
|
|
begin
|
|
i := 0;
|
|
AStore.GetScopeInnerValue(TypeInfo(QWord),i);
|
|
(AObject as TComplexInt64UContentRemotable).Value := i;
|
|
end;
|
|
|
|
function TComplexInt64UContentRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FValue <> 0);
|
|
end;
|
|
|
|
{ TComplexBooleanContentRemotable }
|
|
|
|
class procedure TComplexBooleanContentRemotable.SaveValue(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(Boolean),(AObject as TComplexBooleanContentRemotable).Value);
|
|
end;
|
|
|
|
class procedure TComplexBooleanContentRemotable.LoadValue(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase
|
|
);
|
|
var
|
|
i : Boolean;
|
|
begin
|
|
i := False;
|
|
AStore.GetScopeInnerValue(TypeInfo(Boolean),i);
|
|
(AObject as TComplexBooleanContentRemotable).Value := i;
|
|
end;
|
|
|
|
{ TIntfPoolItem }
|
|
|
|
constructor TIntfPoolItem.Create(AIntf: IInterface; const AUsed: Boolean);
|
|
begin
|
|
FIntf := AIntf as IInterface;
|
|
FUsed := AUsed;
|
|
end;
|
|
|
|
destructor TIntfPoolItem.Destroy();
|
|
begin
|
|
FIntf := nil;
|
|
inherited Destroy();
|
|
end;
|
|
|
|
{ TIntfPool }
|
|
|
|
function TIntfPool.CreateNew(const AUsed : Boolean): TIntfPoolItem;
|
|
begin
|
|
FCS.Acquire();
|
|
try
|
|
Result := TIntfPoolItem.Create(FFactory.CreateInstance(),AUsed);
|
|
FList.Add(Result);
|
|
finally
|
|
FCS.Release();
|
|
end;
|
|
end;
|
|
|
|
function TIntfPool.TryGet(const AIndex: Integer): Boolean;
|
|
var
|
|
itm : TIntfPoolItem;
|
|
begin
|
|
FCS.Acquire();
|
|
try
|
|
itm := TIntfPoolItem(FList[AIndex]);
|
|
Result := not itm.Used;
|
|
if Result then begin
|
|
itm.Used := True;
|
|
end;
|
|
finally
|
|
FCS.Release();
|
|
end;
|
|
end;
|
|
|
|
constructor TIntfPool.Create(const AMin, AMax: Integer; AFactory: IItemFactory);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if not ( ( AMin >= 0 ) and ( AMax >= AMin ) and ( AFactory <> nil ) ) then
|
|
raise Exception.CreateFmt(SERR_InvalidPoolParametersArgs,[AMin,AMax]);
|
|
FMax := AMax;
|
|
FMin := AMin;
|
|
FFactory := AFactory;
|
|
FLock := TSemaphoreObject.Create(FMax);
|
|
FList := TObjectList.Create(True);
|
|
FCS := TCriticalSection.Create();
|
|
for i := 0 to Pred(AMin) do begin
|
|
CreateNew(False);
|
|
end;
|
|
end;
|
|
|
|
destructor TIntfPool.Destroy();
|
|
begin
|
|
FFactory := nil;
|
|
FreeAndNil(FCS);
|
|
FreeAndNil(FLock);
|
|
FreeAndNil(FList);
|
|
inherited Destroy();
|
|
end;
|
|
|
|
function TIntfPool.Get(const ATimeOut : Cardinal): IInterface;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
Result := nil;
|
|
if ( FLock.WaitFor(ATimeOut) = wrSignaled ) then begin
|
|
for i := 0 to Pred(FList.Count) do begin
|
|
if TryGet(i) then begin
|
|
Result := TIntfPoolItem(FList[i]).Intf;
|
|
Break;
|
|
end;
|
|
end;
|
|
if ( Result = nil ) then begin
|
|
Result := CreateNew(True).Intf;
|
|
end;
|
|
end else begin
|
|
raise EServiceException.Create(SERRE_ObjectCreationTimeOut);
|
|
end;
|
|
end;
|
|
|
|
procedure TIntfPool.Release(const AItem: IInterface);
|
|
var
|
|
i : Integer;
|
|
a : IInterface;
|
|
begin
|
|
a := AItem as IInterface;
|
|
for i := 0 to Pred(FList.Count) do begin
|
|
if ( TIntfPoolItem(FList[i]).Intf = a ) then begin
|
|
TIntfPoolItem(FList[i]).Used := False;
|
|
FLock.Release();
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIntfPool.Discard(const AItem : IInterface);
|
|
var
|
|
i : Integer;
|
|
a : IInterface;
|
|
itm : TIntfPoolItem;
|
|
begin
|
|
a := AItem as IInterface;
|
|
for i := 0 to Pred(FList.Count) do begin
|
|
if ( TIntfPoolItem(FList[i]).Intf = a ) then begin
|
|
itm := TIntfPoolItem(FList[i]);
|
|
itm.FIntf := FFactory.CreateInstance() as IInterface;
|
|
itm.Used := False;
|
|
FLock.Release();
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIntfPool.GetInstancesCount() : Integer;
|
|
begin
|
|
FCS.Acquire();
|
|
try
|
|
Result := FList.Count;
|
|
finally
|
|
FCS.Release();
|
|
end;
|
|
end;
|
|
|
|
{ TStringBufferRemotable }
|
|
|
|
class procedure TStringBufferRemotable.Save (
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
if ( AObject <> nil ) then
|
|
buffer := TStringBufferRemotable(AObject).Data
|
|
else
|
|
buffer := '';
|
|
AStore.Put(AName,TypeInfo(string),buffer);
|
|
end;
|
|
|
|
class procedure TStringBufferRemotable.Load (
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
locObj : TStringBufferRemotable;
|
|
begin
|
|
AStore.ReadBuffer(AName,buffer);
|
|
if ( AObject = nil ) then
|
|
AObject := Create();
|
|
locObj := AObject as TStringBufferRemotable;;
|
|
locObj.Data := buffer;
|
|
end;
|
|
|
|
procedure TStringBufferRemotable.Assign (Source : TPersistent );
|
|
begin
|
|
if ( Source = nil ) then begin
|
|
FData := '';
|
|
end else begin
|
|
if Source.InheritsFrom(TStringBufferRemotable) then
|
|
Self.Data := TStringBufferRemotable(Source).Data
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
function TStringBufferRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
begin
|
|
Result := ( Self = ACompareTo ) or
|
|
( Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TStringBufferRemotable) and
|
|
( Self.Data = TStringBufferRemotable(ACompareTo).Data )
|
|
);
|
|
end;
|
|
|
|
function TStringBufferRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (Data <> '');
|
|
end;
|
|
|
|
{ TRemotableRecordEncoder }
|
|
|
|
class procedure TRemotableRecordEncoder.Save(
|
|
ARecord : Pointer;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
recStart, recFieldAddress : PByte;
|
|
typData : PRecordTypeData;
|
|
i : PtrUInt;
|
|
pt : PTypeInfo;
|
|
p : PRecordFieldInfo;
|
|
oldSS,ss : TSerializationStyle;
|
|
typRegItem : TTypeRegistryItem;
|
|
prpName : string;
|
|
typDataObj : TObject;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
AStore.BeginObject(AName,ATypeInfo);
|
|
try
|
|
if not Assigned(ARecord) then begin
|
|
AStore.NilCurrentScope();
|
|
Exit;
|
|
end;
|
|
typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo];
|
|
typDataObj := typRegItem.GetObject(FIELDS_STRING);
|
|
Assert(Assigned(typDataObj),Format(SERR_IncompleteParamTypeRegistration,[AName]));
|
|
typData := PRecordTypeData((typDataObj as TDataObject).Data);
|
|
Assert(Assigned(typData));
|
|
if ( typData^.FieldCount > 0 ) then begin
|
|
recStart := PByte(ARecord);
|
|
ss := AStore.GetSerializationStyle();
|
|
for i := 0 to Pred(typData^.FieldCount) do begin
|
|
p := @(typData^.Fields[i]);
|
|
if p^.Visible then begin
|
|
pt := p^.TypeInfo^;
|
|
if p^.IsAttribute then begin
|
|
if ( ss <> ssAttibuteSerialization ) then
|
|
ss := ssAttibuteSerialization;
|
|
end else begin
|
|
if ( ss <> ssNodeSerialization ) then
|
|
ss := ssNodeSerialization;
|
|
end;
|
|
if ( ss <> AStore.GetSerializationStyle() ) then
|
|
AStore.SetSerializationStyle(ss);
|
|
prpName := typRegItem.GetExternalPropertyName(p^.Name);
|
|
recFieldAddress := recStart;
|
|
Inc(recFieldAddress,p^.Offset);
|
|
case pt^.Kind of
|
|
tkInt64 : AStore.Put(prpName,pt,PInt64(recFieldAddress)^);
|
|
{$IFDEF HAS_QWORD}
|
|
tkQWord : AStore.Put(prpName,pt,PQWord(recFieldAddress)^);
|
|
{$ENDIF}
|
|
tkLString
|
|
{$IFDEF FPC},tkAString{$ENDIF}
|
|
{$IFDEF WST_UNICODESTRING},tkUString{$ENDIF} : AStore.Put(prpName,pt,Pointer(recFieldAddress)^);
|
|
tkClass : AStore.Put(prpName,pt,PObject(recFieldAddress)^);
|
|
tkRecord : AStore.Put(prpName,pt,Pointer(recFieldAddress)^);
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool : AStore.Put(prpName,pt,PBoolean(recFieldAddress)^);
|
|
{$ENDIF}
|
|
tkEnumeration,tkInteger :
|
|
begin
|
|
{$IFDEF WST_DELPHI}
|
|
if ( pt^.Kind = tkEnumeration ) and
|
|
( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
AStore.Put(prpName,pt,PBoolean(recFieldAddress)^);
|
|
end else begin
|
|
{$ENDIF}
|
|
case GetTypeData(pt)^.OrdType of
|
|
otSByte : AStore.Put(prpName,pt,PShortInt(recFieldAddress)^);
|
|
otUByte : AStore.Put(prpName,pt,PByte(recFieldAddress)^);
|
|
otSWord : AStore.Put(prpName,pt,PSmallInt(recFieldAddress)^);
|
|
otUWord : AStore.Put(prpName,pt,PWord(recFieldAddress)^);
|
|
otSLong : AStore.Put(prpName,pt,PLongint(recFieldAddress)^);
|
|
otULong : AStore.Put(prpName,pt,PLongWord(recFieldAddress)^);
|
|
end;
|
|
{$IFDEF WST_DELPHI}
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
tkFloat :
|
|
begin
|
|
case GetTypeData(pt)^.FloatType of
|
|
ftSingle : AStore.Put(prpName,pt,PSingle(recFieldAddress)^);
|
|
ftDouble : AStore.Put(prpName,pt,PDouble(recFieldAddress)^);
|
|
ftExtended : AStore.Put(prpName,pt,PExtended(recFieldAddress)^);
|
|
ftCurr : AStore.Put(prpName,pt,PCurrency(recFieldAddress)^);
|
|
{$IFDEF HAS_COMP}
|
|
ftComp : AStore.Put(prpName,pt,PComp(recFieldAddress)^);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
AStore.EndScope();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
|
|
class procedure TRemotableRecordEncoder.Load(
|
|
var ARecord : Pointer;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
recStart, recFieldAddress : PByte;
|
|
typData : PRecordTypeData;
|
|
i : PtrUInt;
|
|
pt : PTypeInfo;
|
|
propName : String;
|
|
p : PRecordFieldInfo;
|
|
oldSS,ss : TSerializationStyle;
|
|
typRegItem : TTypeRegistryItem;
|
|
typDataObj : TObject;
|
|
begin
|
|
oldSS := AStore.GetSerializationStyle();
|
|
if ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin
|
|
try
|
|
if AStore.IsCurrentScopeNil() then
|
|
Exit;
|
|
typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo];
|
|
typDataObj := typRegItem.GetObject(FIELDS_STRING);
|
|
Assert(Assigned(typDataObj),Format(SERR_IncompleteParamTypeRegistration,[AName]));
|
|
typData := PRecordTypeData((typDataObj as TDataObject).Data);
|
|
Assert(Assigned(typData));
|
|
if ( not Assigned(ARecord) ) then begin
|
|
GetMem(ARecord,typData^.RecordSize);
|
|
FillChar(ARecord^,typData^.RecordSize,#0);
|
|
end;
|
|
|
|
if ( typData^.FieldCount > 0 ) then begin
|
|
recStart := PByte(ARecord);
|
|
for i := 0 to Pred(typData^.FieldCount) do begin
|
|
p := @(typData^.Fields[i]);
|
|
if p^.Visible then begin
|
|
pt := p^.TypeInfo^;
|
|
propName := typRegItem.GetExternalPropertyName(p^.Name);
|
|
if p^.IsAttribute then begin
|
|
ss := ssAttibuteSerialization;
|
|
end else begin
|
|
ss := ssNodeSerialization;
|
|
end;
|
|
if ( ss <> AStore.GetSerializationStyle() ) then
|
|
AStore.SetSerializationStyle(ss);
|
|
recFieldAddress := recStart;
|
|
Inc(recFieldAddress,p^.Offset);
|
|
//try
|
|
Case pt^.Kind Of
|
|
tkInt64 : AStore.Get(pt,propName,PInt64(recFieldAddress)^);
|
|
{$IFDEF HAS_QWORD}
|
|
tkQWord : AStore.Get(pt,propName,PQWord(recFieldAddress)^);
|
|
{$ENDIF}
|
|
tkLString
|
|
{$IFDEF FPC},tkAString{$ENDIF}
|
|
{$IFDEF WST_UNICODESTRING},tkUString{$ENDIF} : AStore.Get(pt,propName,PPointer(recFieldAddress)^);
|
|
{$IFDEF HAS_TKBOOL}
|
|
tkBool : AStore.Get(pt,propName,PBoolean(recFieldAddress)^);
|
|
{$ENDIF}
|
|
tkClass : AStore.Get(pt,propName,PObject(recFieldAddress)^);
|
|
tkRecord : AStore.Get(pt,propName,Pointer(recFieldAddress)^);
|
|
tkEnumeration,tkInteger :
|
|
Begin
|
|
{$IFDEF WST_DELPHI}
|
|
if ( pt^.Kind = tkEnumeration ) and
|
|
( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) )
|
|
then begin
|
|
AStore.Get(pt,propName,PBoolean(recFieldAddress)^);
|
|
end else begin
|
|
{$ENDIF}
|
|
case GetTypeData(pt)^.OrdType Of
|
|
otSByte : AStore.Get(pt,propName,PShortInt(recFieldAddress)^);
|
|
otUByte : AStore.Get(pt,propName,PByte(recFieldAddress)^);
|
|
otSWord : AStore.Get(pt,propName,PSmallInt(recFieldAddress)^);
|
|
otUWord : AStore.Get(pt,propName,PWord(recFieldAddress)^);
|
|
otSLong : AStore.Get(pt,propName,PLongint(recFieldAddress)^);
|
|
otULong : AStore.Get(pt,propName,PLongWord(recFieldAddress)^);
|
|
end;
|
|
{$IFDEF WST_DELPHI}
|
|
end;
|
|
{$ENDIF}
|
|
End;
|
|
tkFloat :
|
|
begin
|
|
case GetTypeData(pt)^.FloatType of
|
|
ftSingle : AStore.Get(pt,propName,PSingle(recFieldAddress)^);
|
|
ftDouble : AStore.Get(pt,propName,PDouble(recFieldAddress)^);
|
|
ftExtended : AStore.Get(pt,propName,PExtended(recFieldAddress)^);
|
|
ftCurr : AStore.Get(pt,propName,PCurrency(recFieldAddress)^);
|
|
{$IFDEF HAS_COMP}
|
|
ftComp : AStore.Get(pt,propName,PComp(recFieldAddress)^);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
End;
|
|
{except
|
|
on E : EServiceException do begin
|
|
if ( persistType = pstAlways ) then
|
|
raise;
|
|
end;
|
|
end;}
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
AStore.EndScopeRead();
|
|
AStore.SetSerializationStyle(oldSS);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TBase64StringRemotable }
|
|
|
|
function TBase64StringRemotable.GetEncodedString : string;
|
|
begin
|
|
Result := Base64Encode(Length(BinaryData),BinaryData[0]);
|
|
end;
|
|
|
|
procedure TBase64StringRemotable.SetEncodedString(const AValue : string);
|
|
begin
|
|
BinaryData := Base64Decode(AValue,[xoDecodeIgnoreIllegalChar]);
|
|
end;
|
|
|
|
{ TBase64StringExtRemotable }
|
|
|
|
function TBase64StringExtRemotable.GetEncodedString : string;
|
|
begin
|
|
Result := Base64Encode(Length(BinaryData),BinaryData[0]);
|
|
end;
|
|
|
|
procedure TBase64StringExtRemotable.SetEncodedString(const AValue : string);
|
|
begin
|
|
BinaryData := Base64Decode(AValue,[xoDecodeIgnoreIllegalChar]);
|
|
end;
|
|
|
|
|
|
procedure initialize_base_service_intf();
|
|
begin
|
|
{$IFDEF HAS_FORMAT_SETTINGS}
|
|
{$IFDEF FPC}
|
|
wst_FormatSettings := DefaultFormatSettings;
|
|
{$ELSE}
|
|
GetLocaleFormatSettings(GetThreadLocale(),wst_FormatSettings);
|
|
{$ENDIF}
|
|
wst_FormatSettings.DecimalSeparator := '.';
|
|
wst_FormatSettings.ThousandSeparator := #0;
|
|
{$ENDIF HAS_FORMAT_SETTINGS}
|
|
|
|
if ( TypeRegistryInstance = nil ) then begin
|
|
TypeRegistryInstance := TTypeRegistry.Create();
|
|
TypeRegistryInstance.RegisterInitializer(TBaseComplexRemotableInitializer);
|
|
TypeRegistryInstance.RegisterInitializer(TSimpleContentObjectRemotableInitializer);
|
|
end;
|
|
if ( SerializeOptionsRegistryInstance = nil ) then
|
|
SerializeOptionsRegistryInstance := TSerializeOptionsRegistry.Create();
|
|
RegisterStdTypes();
|
|
end;
|
|
|
|
procedure finalize_base_service_intf();
|
|
begin
|
|
FreeAndNil(SerializeOptionsRegistryInstance);
|
|
FreeAndNil(TypeRegistryInstance);
|
|
end;
|
|
|
|
|
|
{ TDurationRemotable }
|
|
|
|
function TDurationRemotable.GetAsString: string;
|
|
begin
|
|
Result := ToStr(FData);
|
|
end;
|
|
|
|
function TDurationRemotable.GetNegative: Boolean;
|
|
begin
|
|
Result := FData.Negative;
|
|
end;
|
|
|
|
function TDurationRemotable.GetPart(AIndex: integer): PtrUInt;
|
|
begin
|
|
case AIndex of
|
|
0 : Result := FData.Year;
|
|
1 : Result := FData.Month;
|
|
2 : Result := FData.Day;
|
|
3 : Result := FData.Hour;
|
|
4 : Result := FData.Minute;
|
|
5 : Result := FData.Second;
|
|
6 : Result := FData.FractionalSecond;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TDurationRemotable.SetAsString(const AValue: string);
|
|
begin
|
|
if (AValue<>'') then
|
|
FData := Parse(AValue)
|
|
else
|
|
FillChar(FData,SizeOf(TDurationRec),0);
|
|
end;
|
|
|
|
procedure TDurationRemotable.SetNegative(const AValue: Boolean);
|
|
begin
|
|
FData.Negative := AValue;
|
|
end;
|
|
|
|
procedure TDurationRemotable.SetPart(AIndex: integer; const AValue: PtrUInt);
|
|
begin
|
|
case AIndex of
|
|
0 : FData.Year := AValue;
|
|
1 : FData.Month := AValue;
|
|
2 : FData.Day := AValue;
|
|
3 : FData.Hour := AValue;
|
|
4 : FData.Minute := AValue;
|
|
5 : FData.Second := AValue;
|
|
6 : FData.FractionalSecond := AValue;
|
|
end;
|
|
end;
|
|
|
|
class procedure TDurationRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := TDurationRemotable(AObject).AsString;
|
|
AStore.Put(AName,TypeInfo(string),buffer);
|
|
end;
|
|
|
|
class procedure TDurationRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := '';
|
|
AStore.Get(TypeInfo(string),AName,buffer);
|
|
if ( AObject = nil ) then
|
|
AObject := Create();
|
|
TDurationRemotable(AObject).AsString := buffer;
|
|
end;
|
|
|
|
procedure TDurationRemotable.Assign(Source : TPersistent);
|
|
begin
|
|
if ( Source <> nil ) and Source.InheritsFrom(TDurationRemotable) then
|
|
Self.FData := TDurationRemotable(Source).FData
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
|
|
function TDurationRemotable.Equal(const ACompareTo : TBaseRemotable) : Boolean;
|
|
begin
|
|
if ( Self = ACompareTo ) then begin
|
|
Result := True;
|
|
end else begin
|
|
if ( ACompareTo <> nil ) and ACompareTo.InheritsFrom(TDurationRemotable) then
|
|
Result := ValueEquals(Self.FData,TDurationRemotable(ACompareTo).FData)
|
|
else
|
|
Result := inherited Equal(ACompareTo);
|
|
end;
|
|
end;
|
|
|
|
function TDurationRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (FData.Year <> 0) or (FData.Month <> 0) or (FData.Day <> 0) or
|
|
(FData.Hour <> 0) or (FData.Minute <> 0) or (FData.Second <> 0) or
|
|
(FData.FractionalSecond <> 0);
|
|
end;
|
|
|
|
procedure TDurationRemotable.Clear();
|
|
begin
|
|
FData := ZERO_DURATION;
|
|
end;
|
|
|
|
class function TDurationRemotable.Parse(const ABuffer : string) : TDurationRec;
|
|
begin
|
|
Result := xsd_StrToDuration(ABuffer);
|
|
end;
|
|
|
|
class function TDurationRemotable.ToStr(const AValue: TDurationRec): string;
|
|
begin
|
|
Result := xsd_DurationToStr(AValue);
|
|
end;
|
|
|
|
{ TRemotableTypeInitializer }
|
|
|
|
class function TRemotableTypeInitializer.CanHandle(ATypeInfo : PTypeInfo) : Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
class function TRemotableTypeInitializer.GetItemClass(const ATypeInfo : PTypeInfo) : TTypeRegistryItemClass;
|
|
begin
|
|
Result := TTypeRegistryItem;
|
|
end;
|
|
|
|
|
|
|
|
{ TComplexAnsiCharContentRemotable }
|
|
|
|
class procedure TComplexAnsiCharContentRemotable.LoadValue(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
i : AnsiChar;
|
|
begin
|
|
i := #0;
|
|
AStore.GetScopeInnerValue(TypeInfo(AnsiChar),i);
|
|
(AObject as TComplexAnsiCharContentRemotable).Value := i;
|
|
end;
|
|
|
|
class procedure TComplexAnsiCharContentRemotable.SaveValue(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(AnsiChar),(AObject as TComplexAnsiCharContentRemotable).Value);
|
|
end;
|
|
|
|
{ TComplexWideCharContentRemotable }
|
|
|
|
class procedure TComplexWideCharContentRemotable.LoadValue(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
i : WideChar;
|
|
begin
|
|
i := #0;
|
|
AStore.GetScopeInnerValue(TypeInfo(WideChar),i);
|
|
(AObject as TComplexWideCharContentRemotable).Value := i;
|
|
end;
|
|
|
|
class procedure TComplexWideCharContentRemotable.SaveValue(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase
|
|
);
|
|
begin
|
|
AStore.PutScopeInnerValue(TypeInfo(WideChar),(AObject as TComplexWideCharContentRemotable).Value);
|
|
end;
|
|
|
|
{ TAbstractEncodedStringRemotable }
|
|
|
|
class procedure TAbstractEncodedStringRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
if ( AObject <> nil ) then
|
|
buffer := TAbstractEncodedStringRemotable(AObject).EncodedString
|
|
else
|
|
buffer := '';
|
|
AStore.Put(AName,TypeInfo(string),buffer);
|
|
end;
|
|
|
|
class procedure TAbstractEncodedStringRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := '';
|
|
AStore.Get(TypeInfo(string),AName,buffer);
|
|
if ( AObject = nil ) then
|
|
AObject := Create();
|
|
TAbstractEncodedStringRemotable(AObject).EncodedString := buffer;
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.Assign(Source: TPersistent);
|
|
begin
|
|
if Assigned(Source) then begin
|
|
if Source.InheritsFrom(TAbstractEncodedStringRemotable) then
|
|
Self.BinaryData := Copy(TAbstractEncodedStringRemotable(Source).BinaryData)
|
|
else
|
|
inherited Assign(Source);
|
|
end else begin
|
|
BinaryData := nil;
|
|
end;
|
|
end;
|
|
|
|
function TAbstractEncodedStringRemotable.Equal(const ACompareTo: TBaseRemotable): Boolean;
|
|
begin
|
|
Result := Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TAbstractEncodedStringRemotable) and
|
|
( Length(Self.BinaryData) = Length(TAbstractEncodedStringRemotable(ACompareTo).BinaryData) ) and
|
|
CompareMem(Pointer(Self.BinaryData),Pointer(TAbstractEncodedStringRemotable(ACompareTo).BinaryData),Length(Self.BinaryData));
|
|
end;
|
|
|
|
function TAbstractEncodedStringRemotable.wstHasValue() : Boolean;
|
|
begin
|
|
Result := (Length(FBinaryData) > 0);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.LoadFromStream(AStream: TStream);
|
|
begin
|
|
BinaryData := LoadBufferFromStream(AStream);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.LoadFromBuffer(
|
|
const ABuffer;
|
|
const ABufferLen: Integer
|
|
);
|
|
begin
|
|
SetLength(FBinaryData,ABufferLen);
|
|
if (ABufferLen > 0) then
|
|
Move(ABuffer,FBinaryData[0],ABufferLen);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.LoadFromFile(const AFileName: string);
|
|
begin
|
|
BinaryData := LoadBufferFromFile(AFileName);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.SaveToStream(AStream: TStream);
|
|
begin
|
|
if ( Length(FBinaryData) > 0 ) then
|
|
AStream.Write(FBinaryData[0],Length(FBinaryData));
|
|
end;
|
|
|
|
function TAbstractEncodedStringRemotable.SaveToBuffer(
|
|
var ABuffer;
|
|
const ABufferLen: Integer
|
|
) : Integer;
|
|
var
|
|
c : Integer;
|
|
begin
|
|
c := Length(FBinaryData);
|
|
if (c > ABufferLen) then
|
|
c := ABufferLen;
|
|
if (c > 0) then
|
|
Move(FBinaryData[0],ABuffer,c);
|
|
Result := c;
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringRemotable.SaveToFile(const AFileName: string);
|
|
var
|
|
locStream : TFileStream;
|
|
begin
|
|
locStream := TFileStream.Create(AFileName,fmCreate);
|
|
try
|
|
SaveToStream(locStream);
|
|
finally
|
|
locStream.Free();
|
|
end;
|
|
end;
|
|
|
|
{ TAbstractEncodedStringExtRemotable }
|
|
|
|
class procedure TAbstractEncodedStringExtRemotable.SaveValue(
|
|
AObject: TBaseRemotable;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
s : string;
|
|
begin
|
|
s := (AObject as TAbstractEncodedStringExtRemotable).EncodedString;
|
|
AStore.PutScopeInnerValue(TypeInfo(string),s);
|
|
end;
|
|
|
|
class procedure TAbstractEncodedStringExtRemotable.LoadValue(
|
|
var AObject: TObject;
|
|
AStore: IFormatterBase
|
|
);
|
|
var
|
|
s : string;
|
|
begin
|
|
s := '';
|
|
AStore.GetScopeInnerValue(TypeInfo(string),s);
|
|
(AObject as TAbstractEncodedStringExtRemotable).EncodedString := s;
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.Assign(Source: TPersistent);
|
|
begin
|
|
if Assigned(Source) and Source.InheritsFrom(TAbstractEncodedStringExtRemotable) then begin
|
|
Self.BinaryData := Copy(TAbstractEncodedStringExtRemotable(Source).BinaryData);
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
function TAbstractEncodedStringExtRemotable.Equal(const ACompareTo: TBaseRemotable): Boolean;
|
|
begin
|
|
Result := Assigned(ACompareTo) and
|
|
ACompareTo.InheritsFrom(TAbstractEncodedStringExtRemotable) and
|
|
( Length(Self.BinaryData) = Length(TAbstractEncodedStringExtRemotable(ACompareTo).BinaryData) ) and
|
|
CompareMem(Pointer(Self.BinaryData),Pointer(TAbstractEncodedStringExtRemotable(ACompareTo).BinaryData),Length(Self.BinaryData));
|
|
end;
|
|
|
|
function TAbstractEncodedStringExtRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (Length(FBinaryData) > 0);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.LoadFromStream(AStream: TStream);
|
|
begin
|
|
BinaryData := LoadBufferFromStream(AStream);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.LoadFromBuffer(
|
|
const ABuffer;
|
|
const ABufferLen: Integer
|
|
);
|
|
begin
|
|
SetLength(FBinaryData,ABufferLen);
|
|
if (ABufferLen > 0) then
|
|
Move(ABuffer,FBinaryData[0],ABufferLen);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.LoadFromFile(const AFileName: string);
|
|
begin
|
|
BinaryData := LoadBufferFromFile(AFileName);
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.SaveToStream(AStream: TStream);
|
|
begin
|
|
if ( Length(FBinaryData) > 0 ) then
|
|
AStream.Write(FBinaryData[0],Length(FBinaryData));
|
|
end;
|
|
|
|
function TAbstractEncodedStringExtRemotable.SaveToBuffer(
|
|
var ABuffer;
|
|
const ABufferLen: Integer
|
|
) : Integer;
|
|
var
|
|
c : Integer;
|
|
begin
|
|
c := Length(FBinaryData);
|
|
if (c > ABufferLen) then
|
|
c := ABufferLen;
|
|
if (c > 0) then
|
|
Move(FBinaryData[0],ABuffer,c);
|
|
Result := c;
|
|
end;
|
|
|
|
procedure TAbstractEncodedStringExtRemotable.SaveToFile(const AFileName: string);
|
|
var
|
|
locStream : TFileStream;
|
|
begin
|
|
locStream := TFileStream.Create(AFileName,fmCreate);
|
|
try
|
|
SaveToStream(locStream);
|
|
finally
|
|
locStream.Free();
|
|
end;
|
|
end;
|
|
|
|
{ TBase16StringExtRemotable }
|
|
|
|
function TBase16StringExtRemotable.GetEncodedString: string;
|
|
begin
|
|
Result := Base16Encode(BinaryData[0],Length(BinaryData));
|
|
end;
|
|
|
|
procedure TBase16StringExtRemotable.SetEncodedString(const AValue: string);
|
|
begin
|
|
BinaryData := Base16Decode(AValue,[xoDecodeIgnoreIllegalChar]);
|
|
end;
|
|
|
|
{ TBase16StringRemotable }
|
|
|
|
function TBase16StringRemotable.GetEncodedString: string;
|
|
begin
|
|
Result := Base16Encode(BinaryData[0],Length(BinaryData));
|
|
end;
|
|
|
|
procedure TBase16StringRemotable.SetEncodedString(const AValue: string);
|
|
begin
|
|
BinaryData := Base16Decode(AValue,[xoDecodeIgnoreIllegalChar]);
|
|
end;
|
|
|
|
|
|
|
|
{ TTimeRemotable }
|
|
|
|
function TTimeRemotable.GetAsString : string;
|
|
begin
|
|
Result := ToStr(Data);
|
|
end;
|
|
|
|
function TTimeRemotable.GetMilliSecond: Word;
|
|
begin
|
|
Result := Data.MilliSecond;
|
|
end;
|
|
|
|
function TTimeRemotable.GetOffset(AIndex: integer): Shortint;
|
|
begin
|
|
case AIndex of
|
|
0 : Result := Data.HourOffset;
|
|
1 : Result := Data.MinuteOffset;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TTimeRemotable.GetPart(AIndex: integer): Byte;
|
|
begin
|
|
case AIndex of
|
|
0 : Result := Data.Hour;
|
|
1 : Result := Data.Minute;
|
|
2 : Result := Data.Second;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure TTimeRemotable.SetAsString(const AValue: string);
|
|
begin
|
|
if (AValue<>'') then
|
|
Data := Parse(AValue)
|
|
else
|
|
FillChar(FData,SizeOf(TTimeRec),0);
|
|
end;
|
|
|
|
procedure TTimeRemotable.SetMilliSecond(const AValue: Word);
|
|
begin
|
|
FData.MilliSecond := AValue;
|
|
end;
|
|
|
|
procedure TTimeRemotable.SetOffset(AIndex: integer; const AValue: Shortint);
|
|
begin
|
|
case AIndex of
|
|
0 : FData.HourOffset := AValue;
|
|
1 : FData.MinuteOffset := AValue;
|
|
end;
|
|
end;
|
|
|
|
procedure TTimeRemotable.SetPart(AIndex: integer; const AValue: Byte);
|
|
begin
|
|
case AIndex of
|
|
0 : FData.Hour := AValue;
|
|
1 : FData.Minute := AValue;
|
|
2 : FData.Second := AValue;
|
|
end;
|
|
end;
|
|
|
|
class procedure TTimeRemotable.Save(
|
|
AObject : TBaseRemotable;
|
|
AStore : IFormatterBase;
|
|
const AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := TTimeRemotable(AObject).AsString;
|
|
AStore.Put(AName,TypeInfo(string),buffer);
|
|
end;
|
|
|
|
class procedure TTimeRemotable.Load(
|
|
var AObject : TObject;
|
|
AStore : IFormatterBase;
|
|
var AName : string;
|
|
const ATypeInfo : PTypeInfo
|
|
);
|
|
var
|
|
buffer : string;
|
|
begin
|
|
buffer := '';
|
|
AStore.Get(TypeInfo(string),AName,buffer);
|
|
if ( AObject = nil ) then
|
|
AObject := Create();
|
|
TTimeRemotable(AObject).AsString := buffer;
|
|
end;
|
|
|
|
procedure TTimeRemotable.Assign(Source: TPersistent);
|
|
begin
|
|
if ( Source = nil ) then begin
|
|
Clear();
|
|
end else begin
|
|
if Source.InheritsFrom(TTimeRemotable) then
|
|
Self.Data := TTimeRemotable(Source).Data
|
|
else if Source.InheritsFrom(TDateTimeRemotable) then
|
|
Self.Data := DateTimeToTimeRec(TDateTimeRemotable(Source).AsUTCDate)
|
|
else
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
function TTimeRemotable.Equal(const ACompareTo: TBaseRemotable): Boolean;
|
|
begin
|
|
if ( ACompareTo = nil ) then begin
|
|
Result := ValueEquals(Data,ZERO_TIME );
|
|
end else begin
|
|
if ACompareTo.InheritsFrom(TTimeRemotable) then
|
|
Result := ValueEquals(Self.Data,TTimeRemotable(ACompareTo).Data)
|
|
else
|
|
Result := inherited Equal(ACompareTo);
|
|
end;
|
|
end;
|
|
|
|
function TTimeRemotable.wstHasValue: Boolean;
|
|
begin
|
|
Result := (Data.Hour <> 0) or (Data.Minute <> 0) or (Data.Second <> 0) or
|
|
(Data.HourOffset <> 0) or (Data.MinuteOffset <> 0);
|
|
end;
|
|
|
|
procedure TTimeRemotable.Clear();
|
|
begin
|
|
Data := ZERO_TIME;
|
|
end;
|
|
|
|
class function TTimeRemotable.Parse(const ABuffer: string): TTimeRec;
|
|
begin
|
|
Result := xsd_StrToTime(ABuffer);
|
|
end;
|
|
|
|
class function TTimeRemotable.ToStr(const AValue: TTimeRec): string;
|
|
begin
|
|
Result := xsd_TimeToStr(AValue);
|
|
end;
|
|
|
|
|
|
initialization
|
|
initialize_base_service_intf();
|
|
|
|
finalization
|
|
finalize_base_service_intf();
|
|
|
|
end.
|