diff --git a/wst/trunk/base_binary_formatter.pas b/wst/trunk/base_binary_formatter.pas index 651fa8dab..c1476c702 100644 --- a/wst/trunk/base_binary_formatter.pas +++ b/wst/trunk/base_binary_formatter.pas @@ -22,6 +22,7 @@ uses const sROOT = 'ROOT'; + sSCOPE_INNER_NAME = 'INNER_VAL'; {$IFDEF wst_binary_header} sHEADER = 'HEADER'; {$ENDIF} @@ -86,6 +87,7 @@ type Head : PObjectBufferItem; Last : PObjectBufferItem; Attributes : PObjectBuffer; + InnerData : PDataBuffer; End; PDataBufferList = ^TDataBufferList; @@ -111,6 +113,8 @@ type Const AName : String; const ADataType : TDataType ):PDataBuffer;virtual;abstract; + function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;virtual;abstract; + function GetInnerBuffer():PDataBuffer;virtual;abstract; procedure NilCurrentScope();virtual;abstract; function IsCurrentScopeNil():Boolean;virtual;abstract; property ScopeObject : PDataBuffer Read FScopeObject; @@ -129,6 +133,8 @@ type Const AName : String; const ADataType : TDataType ):PDataBuffer;override; + function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;override; + function GetInnerBuffer():PDataBuffer;override; procedure NilCurrentScope();override; function IsCurrentScopeNil():Boolean;override; End; @@ -147,6 +153,8 @@ type Const AName : String; const ADataType : TDataType ):PDataBuffer;override; + function CreateInnerBuffer(const ADataType : TDataType):PDataBuffer;override; + function GetInnerBuffer():PDataBuffer; procedure NilCurrentScope();override; function IsCurrentScopeNil():Boolean;override; End; @@ -162,6 +170,7 @@ type FHeaderEnterCount : Integer; {$ENDIF} private + function GetCurrentScope: String; function GetCurrentScopeObject():PDataBuffer; procedure SetSerializationStyle(const ASerializationStyle : TSerializationStyle); function GetSerializationStyle():TSerializationStyle; @@ -250,7 +259,6 @@ type constructor Create();override; destructor Destroy();override; - function GetCurrentScope():string; procedure Clear(); procedure BeginObject( @@ -284,11 +292,19 @@ type Const ATypeInfo : PTypeInfo; Const AData ); + procedure PutScopeInnerValue( + const ATypeInfo : PTypeInfo; + const AData + ); procedure Get( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData ); + procedure GetScopeInnerValue( + const ATypeInfo : PTypeInfo; + var AData + ); procedure SaveToStream(AStream : TStream); procedure LoadFromStream(AStream : TStream); @@ -517,16 +533,22 @@ Begin dtEnum : ADest.WriteEnum(ARoot^.EnumData); dtObject : Begin - i := ARoot^.ObjectData^.Count; - ADest.WriteInt32S(i); + ADest.WriteBool(ARoot^.ObjectData^.NilObject) ; + if not ARoot^.ObjectData^.NilObject then begin + i := ARoot^.ObjectData^.Count; + ADest.WriteInt32S(i); - If ( i > 0 ) Then Begin - p := ARoot^.ObjectData^.Head; - For i := 1 To i Do Begin - SaveObjectToStream(p^.Data,ADest); - p := p^.Next; + If ( i > 0 ) Then Begin + p := ARoot^.ObjectData^.Head; + For i := 1 To i Do Begin + SaveObjectToStream(p^.Data,ADest); + p := p^.Next; + End; End; - End; + ADest.WriteBool(Assigned(ARoot^.ObjectData^.InnerData)); + if Assigned(ARoot^.ObjectData^.InnerData) then + SaveObjectToStream(ARoot^.ObjectData^.InnerData,ADest); + end; End; dtArray : Begin @@ -574,11 +596,16 @@ Begin dtEnum : Result^.EnumData := AStoreRdr.ReadEnum(); dtObject : Begin - i := AStoreRdr.ReadInt32S(); - For i := 1 To i Do Begin - AddObj(Result,LoadObjectFromStream(AStoreRdr)); - End; - End; + Result^.ObjectData^.NilObject := AStoreRdr.ReadBool(); + if not Result^.ObjectData^.NilObject then begin + i := AStoreRdr.ReadInt32S(); + For i := 1 To i Do Begin + AddObj(Result,LoadObjectFromStream(AStoreRdr)); + End; + if AStoreRdr.ReadBool() then + Result^.ObjectData^.InnerData := LoadObjectFromStream(AStoreRdr); + end; + end; dtArray : Begin i := AStoreRdr.ReadInt32S(); @@ -606,6 +633,10 @@ begin q^.Data := Nil; Freemem(q); end; + if Assigned(ABuffer^.InnerData) then begin + ClearObj(ABuffer^.InnerData); + ABuffer^.InnerData := nil; + end; //ABuffer^.Head := nil; //ABuffer^.Last := nil; Freemem(ABuffer); @@ -698,6 +729,17 @@ begin Result := CreateObjBuffer(ADataType,AName,ScopeObject); end; +function TObjectStackItem.CreateInnerBuffer(const ADataType: TDataType): PDataBuffer; +begin + Result := CreateObjBuffer(ADataType,sSCOPE_INNER_NAME,nil); + ScopeObject^.ObjectData^.InnerData := Result; +end; + +function TObjectStackItem.GetInnerBuffer(): PDataBuffer; +begin + Result := ScopeObject^.ObjectData^.InnerData; +end; + procedure TObjectStackItem.NilCurrentScope(); begin Assert(ScopeObject^.ObjectData^.Count = 0); @@ -706,7 +748,7 @@ end; function TObjectStackItem.IsCurrentScopeNil(): Boolean; begin - Result:= ScopeObject^.ObjectData^.NilObject; + Result := ScopeObject^.ObjectData^.NilObject; end; //---------------------------------------------------------------- @@ -1040,7 +1082,6 @@ end; procedure TBaseBinaryFormatter.Put(const AName: String; const ATypeInfo: PTypeInfo;const AData); Var - intData : Integer; int64Data : Int64; strData : string; objData : TObject; @@ -1100,6 +1141,129 @@ begin End; end; +procedure TBaseBinaryFormatter.PutScopeInnerValue( + const ATypeInfo : PTypeInfo; + const AData +); +var + int64SData : Int64; + int64UData : QWord; + strData : string; + boolData : Boolean; + enumData : TEnumData; + floatDt : TFloat_Extended_10; +begin + CheckScope(); + case ATypeInfo^.Kind of + tkLString, tkAString : + begin + strData := string(AData); + StackTop().CreateInnerBuffer(dtString)^.StrData^.Data := strData; + end; + tkInt64 : + begin + int64SData := Int64(AData); + StackTop().CreateInnerBuffer(dtInt64S)^.Int64S := int64SData; + end; + tkQWord : + begin + int64UData := QWord(AData); + StackTop().CreateInnerBuffer(dtInt64U)^.Int64U := int64UData; + end; + tkClass : + begin + raise EBinaryFormatterException.Create('Inner Scope value must be a "simple type" value.'); + end; + tkBool : + begin + boolData := Boolean(AData); + StackTop().CreateInnerBuffer(dtBool)^.BoolData := boolData; + end; + tkInteger : + begin + enumData := 0; + case GetTypeData(ATypeInfo)^.OrdType of + otSByte : + begin + enumData := ShortInt(AData); + StackTop().CreateInnerBuffer(dtInt8S)^.Int8S := enumData; + end; + otUByte : + begin + enumData := Byte(AData); + StackTop().CreateInnerBuffer(dtInt8U)^.Int8U := enumData; + end; + otSWord : + begin + enumData := SmallInt(AData); + StackTop().CreateInnerBuffer(dtInt16S)^.Int16S := enumData; + end; + otUWord : + begin + enumData := Word(AData); + StackTop().CreateInnerBuffer(dtInt16U)^.Int16U := enumData; + end; + otSLong : + begin + enumData := LongInt(AData); + StackTop().CreateInnerBuffer(dtInt32S)^.Int32S := enumData; + end; + otULong : + begin + enumData := LongWord(AData); + StackTop().CreateInnerBuffer(dtInt32U)^.Int32U := enumData; + end; + end; + end; + tkEnumeration : + begin + enumData := 0; + case GetTypeData(ATypeInfo)^.OrdType of + otSByte : enumData := ShortInt(AData); + otUByte : enumData := Byte(AData); + otSWord : enumData := SmallInt(AData); + otUWord : enumData := Word(AData); + otSLong : enumData := LongInt(AData); + otULong : enumData := LongWord(AData); + end; + StackTop().CreateInnerBuffer(dtEnum)^.EnumData := enumData; + end; + tkFloat : + begin + floatDt := 0; + case GetTypeData(ATypeInfo)^.FloatType of + ftSingle : + begin + floatDt := Single(AData); + StackTop().CreateInnerBuffer(dtSingle)^.SingleData := floatDt; + end; + ftDouble : + begin + floatDt := Double(AData); + StackTop().CreateInnerBuffer(dtDouble)^.DoubleData := floatDt; + end; + ftExtended : + begin + floatDt := Extended(AData); + StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt; + end; + ftCurr : + begin + floatDt := Currency(AData); + StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt; + end; + ftComp : + begin + floatDt := Comp(AData); + StackTop().CreateInnerBuffer(dtCurrency)^.CurrencyData := floatDt; + end; + else + StackTop().CreateInnerBuffer(dtExtended)^.ExtendedData := floatDt; + end; + end; + end; +end; + procedure TBaseBinaryFormatter.Get( const ATypeInfo: PTypeInfo; var AName: String; @@ -1169,6 +1333,58 @@ begin End; end; +procedure TBaseBinaryFormatter.GetScopeInnerValue( + const ATypeInfo : PTypeInfo; + var AData +); +Var + dataBuffer : PDataBuffer; +begin + CheckScope(); + dataBuffer := StackTop().GetInnerBuffer(); + Case ATypeInfo^.Kind Of + tkInt64 : Int64(AData) := dataBuffer^.Int64S; + tkQWord : QWord(AData) := dataBuffer^.Int64U; + tkLString, + tkAString : string(AData) := dataBuffer^.StrData^.Data; + tkClass : raise EBinaryFormatterException.Create('Inner Scope value must be a "simple type" value.'); + tkBool : Boolean(AData) := dataBuffer^.BoolData; + tkInteger : + begin + case GetTypeData(ATypeInfo)^.OrdType Of + otSByte : ShortInt(AData) := dataBuffer^.Int8S; + otUByte : Byte(AData) := dataBuffer^.Int8U; + otSWord : SmallInt(AData) := dataBuffer^.Int16S; + otUWord : Word(AData) := dataBuffer^.Int16U; + otSLong : LongInt(AData) := dataBuffer^.Int32S; + otULong : LongWord(AData) := dataBuffer^.Int32U; + end; + end; + tkEnumeration : + begin + case GetTypeData(ATypeInfo)^.OrdType Of + otSByte : ShortInt(AData) := dataBuffer^.EnumData; + otUByte : Byte(AData) := dataBuffer^.EnumData; + otSWord : SmallInt(AData) := dataBuffer^.EnumData; + otUWord : Word(AData) := dataBuffer^.EnumData; + otSLong : LongInt(AData) := dataBuffer^.EnumData; + otULong : LongWord(AData) := dataBuffer^.EnumData; + end; + end; + tkFloat : + begin + case GetTypeData(ATypeInfo)^.FloatType of + ftSingle : Single(AData) := dataBuffer^.SingleData; + ftDouble : Double(AData) := dataBuffer^.DoubleData; + ftExtended : Extended(AData) := dataBuffer^.ExtendedData; + ftCurr : Currency(AData) := dataBuffer^.CurrencyData; + else + Comp(AData) := dataBuffer^.ExtendedData; + end; + end; + end; +end; + procedure TBaseBinaryFormatter.SaveToStream(AStream: TStream); Var locStore : IDataStore; @@ -1261,6 +1477,16 @@ begin Inc(FIndex); end; +function TArrayStackItem.CreateInnerBuffer(const ADataType: TDataType): PDataBuffer; +begin + raise EBinaryFormatterException.Create('Array do not support "inner value" feature.'); +end; + +function TArrayStackItem.GetInnerBuffer(): PDataBuffer; +begin + raise EBinaryFormatterException.Create('Array do not support "inner value" feature.'); +end; + procedure TArrayStackItem.NilCurrentScope(); begin end; diff --git a/wst/trunk/base_service_intf.pas b/wst/trunk/base_service_intf.pas index a4e923bed..2d73edaa1 100644 --- a/wst/trunk/base_service_intf.pas +++ b/wst/trunk/base_service_intf.pas @@ -25,6 +25,8 @@ const stArray = stBase + 2; Type + anyURI = type string; + TScopeType = Integer; THeaderDirection = ( hdOut, hdIn ); THeaderDirections = set of THeaderDirection; @@ -140,12 +142,20 @@ type Const ATypeInfo : PTypeInfo; Const AData ); + procedure PutScopeInnerValue( + const ATypeInfo : PTypeInfo; + const AData + ); procedure Get( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData ); - + procedure GetScopeInnerValue( + const ATypeInfo : PTypeInfo; + var AData + ); + procedure SaveToStream(AStream : TStream); procedure LoadFromStream(AStream : TStream); @@ -199,8 +209,74 @@ type TAbstractSimpleRemotable = class(TBaseRemotable) end; + { TBaseDateRemotable } + + TBaseDateRemotable = class(TAbstractSimpleRemotable) + private + FDate : TDateTime; + FYear : Integer; + FMonth : Integer; + FDay : Integer; + protected + procedure SetDate(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 FormatDate(const ADate : TDateTime):string;virtual;abstract; + class function ParseDate(const ABuffer : string):TDateTime;virtual;abstract; + + procedure Assign(Source: TPersistent); override; + + property AsDate : TDateTime read FDate write SetDate; + property Year : Integer read FYear; + property Month : Integer read FMonth; + property Day : Integer read FDay; + end; + + { TDateRemotable } + + TDateRemotable = class(TBaseDateRemotable) + private + FHour: Integer; + FMinute: Integer; + FSecond: Integer; + protected + procedure SetDate(const AValue: TDateTime);override; + public + class function FormatDate(const ADate : TDateTime):string;override; + class function ParseDate(const ABuffer : string):TDateTime;override; + property Hour : Integer read FHour; + property Minute : Integer read FMinute; + property Second : Integer read FSecond; + end; + + TDurationRemotable = class(TBaseDateRemotable) + protected + //class function FormatDate(const ADate : TDateTime):string;override; + //class function ParseDate(const ABuffer : string):TDateTime;override; + 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; end; TBaseComplexRemotableClass = class of TBaseComplexRemotable; @@ -221,13 +297,183 @@ type var AName : string; const ATypeInfo : PTypeInfo );override; - 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; 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; + + { 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 + 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 + 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 + property Value : SmallInt read FValue write FValue; + end; + + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + property Value : Single 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 + property Value : string read FValue write FValue; + 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 } @@ -743,7 +989,9 @@ type FNameSpace: string; FDeclaredName : string; FOptions: TTypeRegistryItemOptions; - FSynonymTable : TStringList; + FSynonymTable : TStrings; + FExternalNames : TStrings; + FInternalNames : TStrings; public constructor Create( ANameSpace : string; @@ -751,8 +999,12 @@ type Const ADeclaredName : string = '' ); destructor Destroy();override; - procedure AddPascalSynonym(const ASynonym : string);//inline; + function AddPascalSynonym(const ASynonym : string):TTypeRegistryItem;//inline; function IsSynonym(const APascalTypeName : string):Boolean;//inline; + + procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); + function GetExternalPropertyName(const APropName : string) : string; + function GetInternalPropertyName(const AExtPropName : string) : string; property DataType : PTypeInfo read FDataType; property NameSpace : string read FNameSpace; @@ -847,6 +1099,8 @@ begin r.Register(sXSD_NS,TypeInfo(string),'string').AddPascalSynonym('string'); r.Register(sXSD_NS,TypeInfo(AnsiString),'ansistring').AddPascalSynonym('ansistring'); + r.Register(sXSD_NS,TypeInfo(anyURI),'anyURI').AddPascalSynonym('anyURI'); + r.Register(sXSD_NS,TypeInfo(boolean),'boolean').AddPascalSynonym('boolean'); r.Register(sXSD_NS,TypeInfo(Byte),'unsignedByte').AddPascalSynonym('Byte'); @@ -854,13 +1108,16 @@ begin 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),'int').AddPascalSynonym('QWord'); + 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),'double').AddPascalSynonym('Extended'); + r.Register(sXSD_NS,TypeInfo(Extended),'decimal').AddPascalSynonym('Extended'); + + r.Register(sXSD_NS,TypeInfo(TDateRemotable),'dateTime').AddPascalSynonym('TDateRemotable'); + r.Register(sXSD_NS,TypeInfo(TDurationRemotable),'duration').AddPascalSynonym('TDurationRemotable'); ri := r.Register(sWST_BASE_NS,TypeInfo(TBaseArrayRemotable),'TBaseArrayRemotable'); ri.Options := ri.Options + [trioNonVisibleToMetadataService]; @@ -889,6 +1146,25 @@ begin 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(TComplexBooleanContentRemotable),'boolean').AddPascalSynonym('TComplexBooleanContentRemotable'); end; function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType; @@ -941,15 +1217,15 @@ Type private FAttributeFieldList : TStringList; private - FElementClass: TBaseComplexRemotableClass; + FElementClass: TAbstractComplexRemotableClass; procedure AddAttributeField(const AAttributeField : string); function GetAttributeCount: Integer; function GetAttributeField(AIndex : Integer): string; public - constructor Create(const AElementClass : TBaseComplexRemotableClass); + constructor Create(const AElementClass : TAbstractComplexRemotableClass); destructor Destroy();override; function IsAttributeField(const AField : string):Boolean; - property ElementClass : TBaseComplexRemotableClass read FElementClass; + property ElementClass : TAbstractComplexRemotableClass read FElementClass; property AttributeFieldCount : Integer read GetAttributeCount; property AttributeField[AIndex : Integer] : string read GetAttributeField; end; @@ -962,12 +1238,12 @@ Type private function GetCount: Integer; function GetItem(AIndex : Integer): TSerializeOptions; - function IndexOf(const AElementClass : TBaseComplexRemotableClass):Integer; + function IndexOf(const AElementClass : TAbstractComplexRemotableClass):Integer; public constructor Create(); destructor Destroy();override; - function RegisterClass(const AElementClass : TBaseComplexRemotableClass):TSerializeOptions; - function Find(const AElementClass : TBaseComplexRemotableClass):TSerializeOptions; + 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; @@ -995,7 +1271,7 @@ begin end; function TSerializeOptionsRegistry.IndexOf( - const AElementClass: TBaseComplexRemotableClass + const AElementClass: TAbstractComplexRemotableClass ): Integer; begin for Result := 0 to Pred(Count) do begin @@ -1017,7 +1293,7 @@ begin end; function TSerializeOptionsRegistry.RegisterClass( - const AElementClass: TBaseComplexRemotableClass + const AElementClass: TAbstractComplexRemotableClass ): TSerializeOptions; var i, j, k, c : Integer; @@ -1038,9 +1314,7 @@ begin Result := FList[i] as TSerializeOptions; end; -function TSerializeOptionsRegistry.Find( - const AElementClass: TBaseComplexRemotableClass -): TSerializeOptions; +function TSerializeOptionsRegistry.Find(const AElementClass: TAbstractComplexRemotableClass): TSerializeOptions; var i : Integer; begin @@ -1069,7 +1343,7 @@ begin Result := FAttributeFieldList[AIndex]; end; -constructor TSerializeOptions.Create(const AElementClass: TBaseComplexRemotableClass); +constructor TSerializeOptions.Create(const AElementClass: TAbstractComplexRemotableClass); begin FElementClass := AElementClass; FAttributeFieldList := TStringList.Create(); @@ -1105,6 +1379,8 @@ Var floatDt : TFloatBuffer; p : PPropInfo; oldSS,ss : TSerializationStyle; + typRegItem : TTypeRegistryItem; + prpName : string; begin oldSS := AStore.GetSerializationStyle(); AStore.BeginObject(AName,ATypeInfo); @@ -1118,6 +1394,7 @@ 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; @@ -1131,26 +1408,27 @@ begin end; if ( ss <> AStore.GetSerializationStyle() ) then AStore.SetSerializationStyle(ss); + prpName := typRegItem.GetExternalPropertyName(p^.Name); case pt^.Kind of tkInt64,tkQWord : begin int64Data := GetOrdProp(AObject,p^.Name); - AStore.Put(p^.Name,pt,int64Data); + AStore.Put(prpName,pt,int64Data); end; tkLString, tkAString : begin strData := GetStrProp(AObject,p^.Name); - AStore.Put(p^.Name,pt,strData); + AStore.Put(prpName,pt,strData); end; tkClass : begin objData := GetObjectProp(AObject,p^.Name); - AStore.Put(p^.Name,pt,objData); + AStore.Put(prpName,pt,objData); end; tkBool : begin boolData := Boolean(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,boolData); + AStore.Put(prpName,pt,boolData); end; tkEnumeration,tkInteger : begin @@ -1159,32 +1437,32 @@ begin otSByte : begin enumData.ShortIntData := ShortInt(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.ShortIntData); + AStore.Put(prpName,pt,enumData.ShortIntData); end; otUByte : begin enumData.ByteData := Byte(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.ByteData); + AStore.Put(prpName,pt,enumData.ByteData); end; otSWord : begin enumData.SmallIntData := SmallInt(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.SmallIntData); + AStore.Put(prpName,pt,enumData.SmallIntData); end; otUWord : begin enumData.WordData := Word(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.WordData); + AStore.Put(prpName,pt,enumData.WordData); end; otSLong : begin enumData.SLongIntData := LongInt(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.SLongIntData); + AStore.Put(prpName,pt,enumData.SLongIntData); end; otULong : begin enumData.ULongIntData := LongWord(GetOrdProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,enumData.ULongIntData); + AStore.Put(prpName,pt,enumData.ULongIntData); end; end; end; @@ -1195,27 +1473,27 @@ begin ftSingle : begin floatDt.SingleData := Single(GetFloatProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,floatDt.SingleData); + AStore.Put(prpName,pt,floatDt.SingleData); end; ftDouble : begin floatDt.DoubleData := Double(GetFloatProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,floatDt.DoubleData); + AStore.Put(prpName,pt,floatDt.DoubleData); end; ftExtended : begin floatDt.ExtendedData := Extended(GetFloatProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,floatDt.ExtendedData); + AStore.Put(prpName,pt,floatDt.ExtendedData); end; ftCurr : begin floatDt.CurrencyData := Currency(GetFloatProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,floatDt.CurrencyData); + AStore.Put(prpName,pt,floatDt.CurrencyData); end; ftComp : begin floatDt.CompData := Comp(GetFloatProp(AObject,p^.Name)); - AStore.Put(p^.Name,pt,floatDt.CompData); + AStore.Put(prpName,pt,floatDt.CompData); end; end; end; @@ -1235,7 +1513,7 @@ end; Type TFloatExtendedType = Extended; class procedure TBaseComplexRemotable.Load( - Var AObject : TObject; + Var AObject : TObject; AStore : IFormatterBase; var AName : String; const ATypeInfo : PTypeInfo @@ -1257,6 +1535,7 @@ Var persistType : TPropStoreType; objTypeData : PTypeData; oldSS,ss : TSerializationStyle; + typRegItem : TTypeRegistryItem; begin oldSS := AStore.GetSerializationStyle(); AStore.BeginScopeRead(AName,ATypeInfo); @@ -1270,12 +1549,13 @@ begin 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; - propName := p^.Name; + propName := typRegItem.GetExternalPropertyName(p^.Name); if IsAttributeProperty(p^.Name) then begin ss := ssAttibuteSerialization; end else begin @@ -1288,26 +1568,26 @@ begin tkInt64,tkQWord : Begin AStore.Get(pt,propName,int64Data); - SetOrdProp(AObject,propName,int64Data); + SetOrdProp(AObject,p^.Name,int64Data); End; tkLString, tkAString : Begin AStore.Get(pt,propName,strData); - SetStrProp(AObject,propName,strData); + SetStrProp(AObject,p^.Name,strData); End; tkBool : Begin AStore.Get(pt,propName,boolData); - SetOrdProp(AObject,propName,Ord(boolData)); + SetOrdProp(AObject,p^.Name,Ord(boolData)); End; tkClass : Begin - objData := GetObjectProp(AObject,propName); + objData := GetObjectProp(AObject,p^.Name); objDataCreateHere := not Assigned(objData); try AStore.Get(pt,propName,objData); if objDataCreateHere then - SetObjectProp(AObject,propName,objData); + SetObjectProp(AObject,p^.Name,objData); finally if objDataCreateHere then FreeAndNil(objData); @@ -1348,7 +1628,7 @@ begin int64Data := enumData.ULongIntData; End; End; - SetOrdProp(AObject,propName,int64Data); + SetOrdProp(AObject,p^.Name,int64Data); End; tkFloat : Begin @@ -1380,7 +1660,7 @@ begin floatDt := floatBuffer.CompData; End; End; - SetFloatProp(AObject,propName,floatDt); + SetFloatProp(AObject,p^.Name,floatDt); End; End; except @@ -1401,83 +1681,6 @@ begin end; end; -class procedure TBaseComplexRemotable.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 TBaseComplexRemotable.RegisterAttributeProperties( - const APropertList : array of shortstring -); -var - i : Integer; -begin - for i := Low(APropertList) to High(APropertList) do - RegisterAttributeProperty(APropertList[i]); -end; - -class function TBaseComplexRemotable.IsAttributeProperty(const AProperty: shortstring): Boolean; -var - ri : TSerializeOptions; - pc : TClass; -begin - Result := False; - if ( Self = TBaseComplexRemotable ) then - Exit; - pc := Self; - while Assigned(pc) and pc.InheritsFrom(TBaseComplexRemotable) do begin - ri := GetSerializeOptionsRegistry().Find(TBaseComplexRemotableClass(pc)); - if Assigned(ri) then begin - Result := ri.IsAttributeField(AProperty); - Exit; - end; - pc := pc.ClassParent; - end; -end; - -procedure TBaseComplexRemotable.Assign(Source: TPersistent); -var - propList : PPropList; - i, propCount, propListLen : Integer; - p, sp : PPropInfo; - selfTypeInfo : PTypeInfo; -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 - Assigned(p^.SetProc) - then begin - case p^.PropType^.Kind of - tkInt64,tkQWord, tkBool, tkEnumeration,tkInteger : - SetOrdProp(Self,p,GetOrdProp(Source,p^.Name)); - tkLString, tkAString : - SetStrProp(Self,p,GetStrProp(Source,p^.Name)); - tkClass : - SetObjectProp(Self,p,GetObjectProp(Source,p^.Name)); - tkFloat : - SetFloatProp(Self,p,GetFloatProp(Source,p^.Name)); - end; - end; - end; - finally - Freemem(propList,propListLen*SizeOf(Pointer)); - end; - end; -end; - { TBaseObjectArrayRemotable } function TBaseObjectArrayRemotable.GetItem(AIndex: Integer): TBaseRemotable; @@ -1823,12 +2026,15 @@ end; destructor TTypeRegistryItem.Destroy(); begin + FreeAndNil(FInternalNames); + FreeAndNil(FExternalNames); FreeAndNil(FSynonymTable); inherited Destroy(); end; -procedure TTypeRegistryItem.AddPascalSynonym(const ASynonym: string); //inline; +function TTypeRegistryItem.AddPascalSynonym(const ASynonym: string):TTypeRegistryItem; //inline; begin + Result := Self; if AnsiSameText(ASynonym,DataType^.Name) then Exit; if not Assigned(FSynonymTable) then begin @@ -1846,6 +2052,33 @@ begin Result := ( FSynonymTable.IndexOf(APascalTypeName) >= 0 ) ; end; +procedure TTypeRegistryItem.RegisterExternalPropertyName(const APropName,AExtPropName: string); +begin + if not Assigned(FExternalNames) then begin + FExternalNames := TStringList.Create(); + FInternalNames := TStringList.Create(); + end; + FExternalNames.Values[APropName] := AExtPropName; + FInternalNames.Values[AExtPropName] := APropName; +end; + +function TTypeRegistryItem.GetExternalPropertyName(const APropName: string): string; +begin + if Assigned(FExternalNames) and ( FExternalNames.IndexOfName(APropName) <> -1 ) then begin + Result := FExternalNames.Values[APropName]; + end else begin + Result := APropName; + end; +end; + +function TTypeRegistryItem.GetInternalPropertyName(const AExtPropName: string): string; +begin + if Assigned(FInternalNames) and ( FInternalNames.IndexOfName(AExtPropName) <> -1 ) then + Result := FInternalNames.Values[AExtPropName] + else + Result := AExtPropName; +end; + { TTypeRegistry } function TTypeRegistry.GetCount: Integer; @@ -2848,6 +3081,854 @@ begin 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; +begin + Result := False; + if ( Self = TBaseComplexRemotable ) then + Exit; + pc := Self; + while Assigned(pc) and pc.InheritsFrom(TBaseComplexRemotable) do begin + ri := GetSerializeOptionsRegistry().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; +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 + Assigned(p^.SetProc) + then begin + case p^.PropType^.Kind of + tkInt64,tkQWord, tkBool, tkEnumeration,tkInteger : + SetOrdProp(Self,p,GetOrdProp(Source,p^.Name)); + tkLString, tkAString : + SetStrProp(Self,p,GetStrProp(Source,p^.Name)); + tkClass : + SetObjectProp(Self,p,GetObjectProp(Source,p^.Name)); + tkFloat : + SetFloatProp(Self,p,GetFloatProp(Source,p^.Name)); + end; + end; + end; + finally + Freemem(propList,propListLen*SizeOf(Pointer)); + end; + end; +end; + +{ TBaseComplexSimpleContentRemotable } + +class procedure TBaseComplexSimpleContentRemotable.Save( + AObject: TBaseRemotable; + AStore: IFormatterBase; + const AName: string; + const ATypeInfo: PTypeInfo +); +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; + 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(); + AStore.SetSerializationStyle(ssAttibuteSerialization); + for i := 0 to Pred(propCount) do begin + p := propList^[i]; + pt := p^.PropType; + propName := tr.ItemByTypeInfo[pt].GetExternalPropertyName(p^.Name); + if IsStoredProp(AObject,p) then begin + case pt^.Kind of + tkInt64,tkQWord : + begin + int64Data := GetOrdProp(AObject,p^.Name); + AStore.Put(propName,pt,int64Data); + end; + tkLString, tkAString : + 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; + tkBool : + begin + boolData := Boolean(GetOrdProp(AObject,p^.Name)); + AStore.Put(propName,pt,boolData); + end; + tkEnumeration,tkInteger : + begin + FillChar(enumData,SizeOf(enumData),#0); + case GetTypeData(p^.PropType)^.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; + end; + tkFloat : + begin + FillChar(floatDt,SizeOf(floatDt),#0); + case GetTypeData(p^.PropType)^.FloatType of + ftSingle : + begin + floatDt.SingleData := Single(GetFloatProp(AObject,p^.Name)); + AStore.Put(propName,pt,floatDt.SingleData); + end; + ftDouble : + begin + floatDt.DoubleData := Double(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 := Currency(GetFloatProp(AObject,p^.Name)); + AStore.Put(propName,pt,floatDt.CurrencyData); + end; + ftComp : + begin + floatDt.CompData := Comp(GetFloatProp(AObject,p^.Name)); + AStore.Put(propName,pt,floatDt.CompData); + end; + end; + end; + end; + end; + end; + finally + Freemem(propList,propListLen*SizeOf(Pointer)); + end; + end; + finally + AStore.EndScope(); + AStore.SetSerializationStyle(oldSS); + end; +end; + +class procedure TBaseComplexSimpleContentRemotable.Load( + var AObject: TObject; + AStore: IFormatterBase; + var AName: string; + const ATypeInfo: PTypeInfo +); +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 : TSerializationStyle; + tr : TTypeRegistry; +begin + oldSS := AStore.GetSerializationStyle(); + AStore.BeginScopeRead(AName,ATypeInfo); + 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(); + 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; + propName := tr.ItemByTypeInfo[pt].GetExternalPropertyName(p^.Name); + try + Case pt^.Kind Of + tkInt64,tkQWord : + Begin + AStore.Get(pt,propName,int64Data); + SetOrdProp(AObject,p^.Name,int64Data); + End; + tkLString, tkAString : + Begin + AStore.Get(pt,propName,strData); + SetStrProp(AObject,p^.Name,strData); + End; + tkBool : + Begin + AStore.Get(pt,propName,boolData); + SetOrdProp(AObject,p^.Name,Ord(boolData)); + End; + 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(p^.PropType)^.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(p^.PropType)^.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; + +{ TComplexInt32SContentRemotable } + +class procedure TComplexInt32SContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(LongInt),(AObject as TComplexInt32SContentRemotable).Value); +end; + +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; + +{ TComplexInt32UContentRemotable } + +procedure TComplexInt32UContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(LongWord),(AObject as TComplexInt32UContentRemotable).Value); +end; + +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; + +{ TComplexInt16SContentRemotable } + +procedure TComplexInt16SContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(SmallInt),(AObject as TComplexInt16SContentRemotable).Value); +end; + +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; + +{ TComplexInt16UContentRemotable } + +procedure TComplexInt16UContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Word),(AObject as TComplexInt16UContentRemotable).Value); +end; + +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; + +{ TComplexFloatExtendedContentRemotable } + +procedure TComplexFloatExtendedContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Extended),(AObject as TComplexFloatExtendedContentRemotable).Value); +end; + +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; + +{ TComplexFloatDoubleContentRemotable } + +procedure TComplexFloatDoubleContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Double),(AObject as TComplexFloatDoubleContentRemotable).Value); +end; + +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; + +{ 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; + +{ TDateRemotable } + +procedure TDateRemotable.SetDate(const AValue: TDateTime); +var + hh, mn, ss, ssss : Word; +begin + inherited SetDate(AValue); + DecodeTime(AsDate,hh,mn,ss,ssss); + FHour := hh; + FMinute := mn; + FSecond := ss; +end; + +class function TDateRemotable.FormatDate(const ADate: TDateTime): string; +var + s, buffer : string; + d, m, y : Word; + hh, mn, ss, ssss : Word; +begin + //'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)? + + DecodeDate(ADate,y,m,d); + s := IntToStr(y); + buffer := IntToStr(m); + if ( m < 10 ) then + buffer := '0' + buffer; + s := Format('%s-%s',[s,buffer]); + + buffer := IntToStr(d); + if ( d < 10 ) then + buffer := '0' + buffer; + s := Format('%s-%s',[s,buffer]); + + DecodeTime(ADate,hh,mn,ss,ssss); + buffer := IntToStr(hh); + if ( hh < 10 ) then + buffer := '0' + buffer; + s := Format('%sT%s',[s,buffer]); + + buffer := IntToStr(mn); + if ( mn < 10 ) then + buffer := '0' + buffer; + s := Format('%s:%s',[s,buffer]); + + buffer := IntToStr(ss); + if ( ss < 10 ) then + buffer := '0' + buffer; + s := Format('%s:%s',[s,buffer]); + + Result := s; +end; + +class function TDateRemotable.ParseDate(const ABuffer: string): TDateTime; +var + buffer : string; + bufferPos, bufferLen : Integer; + + function ReadInt() : Integer; + var + neg : Boolean; + s : shortstring; + begin + neg := False; + Result := 0; + + while ( bufferPos <= bufferLen ) and ( buffer[bufferPos] < #33 ) do begin + Inc(bufferPos); + end; + + if ( bufferPos <= bufferLen ) then begin + if ( ABuffer[bufferPos] = '-' ) then begin + neg := True; + Inc(bufferPos); + end; + end; + s := ''; + while ( bufferPos <= bufferLen ) and ( buffer[bufferPos] in ['0'..'9'] ) do begin + s := s + buffer[bufferPos]; + Inc(bufferPos); + end; + if ( Length(s) = 0 ) then + raise EServiceException.Create('Invalid INTEGER BUFFER'); + Result := StrToInt(s); + if neg then begin + Result := -Result; + end; + end; + +var + s: string; + d, m, y : Word; + hh, mn, ss, ssss : Word; +begin + //'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)? + + buffer := Trim(ABuffer); + bufferPos := 0; + bufferLen := Length(buffer); + + y := ReadInt(); + Inc(bufferPos); + + m := ReadInt(); + Inc(bufferPos); + + d := ReadInt(); + Inc(bufferPos); + + hh := ReadInt(); + Inc(bufferPos); + + mn := ReadInt(); + Inc(bufferPos); + + ss := ReadInt(); + + Result := EncodeDate(y,m,d) + EncodeTime(hh,mn,ss,0); +end; + +{ TBaseDateRemotable } + +procedure TBaseDateRemotable.SetDate(const AValue: TDateTime); +var + y, m, d : Word; +begin + DecodeDate(AValue,y,m,d); + FDate := AValue; + FYear := y; + FMonth := m; + FDay := d; +end; + +procedure TBaseDateRemotable.Save( + AObject : TBaseRemotable; + AStore : IFormatterBase; + const AName : string; + const ATypeInfo : PTypeInfo +); +var + buffer : string; +begin + buffer := FormatDate(TDateRemotable(AObject).AsDate); + AStore.BeginObject(AName,ATypeInfo); + try + AStore.PutScopeInnerValue(TypeInfo(string),buffer); + finally + AStore.EndScope(); + end; +end; + +procedure TBaseDateRemotable.Load( + var AObject : TObject; + AStore : IFormatterBase; + var AName : string; + const ATypeInfo : PTypeInfo +); +var + strBuffer : string; +begin + AStore.BeginScopeRead(AName,ATypeInfo, stObject); + try + strBuffer := ''; + AStore.GetScopeInnerValue(TypeInfo(string),strBuffer); + (AObject as TDateRemotable).AsDate := ParseDate(strBuffer); + finally + AStore.EndScopeRead(); + end; +end; + +procedure TBaseDateRemotable.Assign(Source: TPersistent); +begin + if Source.InheritsFrom(TDateRemotable) then begin + FDate := TDateRemotable(Source).AsDate; + end else begin + inherited Assign(Source); + end; +end; + +{ TComplexInt8SContentRemotable } + +procedure TComplexInt8SContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(ShortInt),(AObject as TComplexInt8SContentRemotable).Value); +end; + +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; + +{ TComplexInt8UContentRemotable } + +procedure TComplexInt8UContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Byte),(AObject as TComplexInt8UContentRemotable).Value); +end; + +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; + +{ TComplexFloatSingleContentRemotable } + +procedure TComplexFloatSingleContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Single),(AObject as TComplexFloatSingleContentRemotable).Value); +end; + +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; + +{ TComplexInt64SContentRemotable } + +procedure TComplexInt64SContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Int64),(AObject as TComplexInt64SContentRemotable).Value); +end; + +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; + +{ TComplexInt64UContentRemotable } + +procedure TComplexInt64UContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(QWord),(AObject as TComplexInt64UContentRemotable).Value); +end; + +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; + +{ TComplexBooleanContentRemotable } + +procedure TComplexBooleanContentRemotable.SaveValue( + AObject : TBaseRemotable; + AStore : IFormatterBase +); +begin + AStore.PutScopeInnerValue(TypeInfo(Boolean),(AObject as TComplexBooleanContentRemotable).Value); +end; + +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; + initialization TypeRegistryInstance := TTypeRegistry.Create(); SerializeOptionsRegistryInstance := TSerializeOptionsRegistry.Create(); diff --git a/wst/trunk/base_soap_formatter.pas b/wst/trunk/base_soap_formatter.pas index 977a45051..acb0bc4cb 100644 --- a/wst/trunk/base_soap_formatter.pas +++ b/wst/trunk/base_soap_formatter.pas @@ -26,8 +26,8 @@ Const sXML_NS = 'xmlns'; sXSI_NS = 'http://www.w3.org/1999/XMLSchema-instance'; - sXSI_TYPE = 'xsi:type'; - sXSI_NIL = 'xsi:nil'; + sTYPE = 'type'; + sNIL = 'nil'; sSOAP_ENC = 'http://schemas.xmlsoap.org/soap/encoding/'; sSOAP_ENC_ABR = 'SOAP-ENC'; @@ -198,6 +198,10 @@ Type ):boolean; function FindAttributeByValueInScope(Const AAttValue : String):String; function FindAttributeByNameInScope(Const AAttName : String):String; + function GetNameSpaceShortName( + const ANameSpace : string; + const ACreateIfNotFound : Boolean + ):shortstring; protected function GetCurrentScope():String; function GetCurrentScopeObject():TDOMElement; @@ -254,11 +258,19 @@ Type Const ATypeInfo : PTypeInfo; Const AData ); + procedure PutScopeInnerValue( + const ATypeInfo : PTypeInfo; + const AData + ); procedure Get( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData ); + procedure GetScopeInnerValue( + const ATypeInfo : PTypeInfo; + var AData + ); procedure SaveToStream(AStream : TStream); procedure LoadFromStream(AStream : TStream); @@ -529,6 +541,22 @@ begin Result := ''; end; +function TSOAPBaseFormatter.GetNameSpaceShortName( + const ANameSpace : string; + const ACreateIfNotFound : Boolean +): shortstring; +begin + Result := FindAttributeByValueInScope(ANameSpace); + if IsStrEmpty(Result) then begin + if ACreateIfNotFound then begin + Result := 'ns' + IntToStr(NextNameSpaceCounter()); + AddScopeAttribute('xmlns:'+Result, ANameSpace); + end; + end else begin + Result := Copy(Result,Length('xmlns:')+1,MaxInt); + end; +end; + procedure TSOAPBaseFormatter.CheckScope(); begin If Not HasScope() Then @@ -570,26 +598,29 @@ begin Result := FDoc.CreateElement(strNodeName); Result.AppendChild(FDoc.CreateTextNode(AData)); GetCurrentScopeObject().AppendChild(Result); + If ( EncodingStyle = Encoded ) Then Begin + regItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo]; + strName := regItem.DeclaredName; + namespaceLongName := regItem.NameSpace; + If Not IsStrEmpty(namespaceLongName) Then Begin + namespaceShortName := FindAttributeByValueInScope(namespaceLongName); + If IsStrEmpty(namespaceShortName) Then Begin + namespaceShortName := Format('ns%d',[NextNameSpaceCounter()]); + AddScopeAttribute(sXML_NS + ':'+namespaceShortName,namespaceLongName); + End Else Begin + namespaceShortName := ExtractNameSpaceShortName(namespaceShortName);//Copy(namespaceShortName,AnsiPos(':',namespaceShortName) + 1,MaxInt); + End; + strName := Format('%s:%s',[namespaceShortName,strName]) + End; + namespaceShortName := GetNameSpaceShortName(sXSI_NS,True); + if not IsStrEmpty(namespaceShortName) then + namespaceShortName := namespaceShortName + ':'; + (Result As TDOMElement).SetAttribute(namespaceShortName + sTYPE,strName); + End; end else begin Result := GetCurrentScopeObject(); (Result as TDOMElement).SetAttribute(strNodeName,AData); end; - If ( EncodingStyle = Encoded ) Then Begin - regItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo]; - strName := regItem.DeclaredName; - namespaceLongName := regItem.NameSpace; - If Not IsStrEmpty(namespaceLongName) Then Begin - namespaceShortName := FindAttributeByValueInScope(namespaceLongName); - If IsStrEmpty(namespaceShortName) Then Begin - namespaceShortName := Format('ns%d',[NextNameSpaceCounter()]); - AddScopeAttribute(sXML_NS + ':'+namespaceShortName,namespaceLongName); - End Else Begin - namespaceShortName := ExtractNameSpaceShortName(namespaceShortName);//Copy(namespaceShortName,AnsiPos(':',namespaceShortName) + 1,MaxInt); - End; - strName := Format('%s:%s',[namespaceShortName,strName]) - End; - (Result As TDOMElement).SetAttribute(sXSI_TYPE,strName); - End; end; function TSOAPBaseFormatter.PutEnum( @@ -598,7 +629,11 @@ function TSOAPBaseFormatter.PutEnum( const AData: TEnumIntType ): TDOMNode; begin - Result := InternalPutData(AName,ATypeInfo,GetEnumName(ATypeInfo,AData)); + Result := InternalPutData( + AName, + ATypeInfo, + GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetExternalPropertyName(GetEnumName(ATypeInfo,AData)) + ); end; function TSOAPBaseFormatter.PutBool( @@ -688,7 +723,7 @@ begin else Result := locElt.NodeValue; end else begin - Error('Param not found : "%s"',[AName]); + Error('Param or Attribute not found : "%s"',[AName]); end; //WriteLn(StringOfChar(' ',FStack.Count), AName,' = ',Result); end; @@ -824,7 +859,7 @@ procedure TSOAPBaseFormatter.BeginObject( ); Var typData : TTypeRegistryItem; - nmspc,nmspcSH : string; + nmspc,nmspcSH, xsiNmspcSH : string; mustAddAtt : Boolean; strNodeName : string; begin @@ -858,8 +893,12 @@ begin BeginScope(strNodeName,''); If mustAddAtt Then AddScopeAttribute('xmlns:'+nmspcSH, nmspc); - if ( EncodingStyle = Encoded ) then - AddScopeAttribute(sXSI_TYPE,Format('%s:%s',[nmspcSH,typData.DeclaredName])); + if ( EncodingStyle = Encoded ) then begin + xsiNmspcSH := GetNameSpaceShortName(sXSI_NS,True); + if not IsStrEmpty(xsiNmspcSH) then + xsiNmspcSH := xsiNmspcSH + ':'; + AddScopeAttribute(xsiNmspcSH + sTYPE,Format('%s:%s',[nmspcSH,typData.DeclaredName])); + end; StackTop().SetNameSpace(nmspc); end; @@ -916,27 +955,39 @@ begin end; procedure TSOAPBaseFormatter.NilCurrentScope(); +var + nmspcSH : shortstring; begin CheckScope(); - GetCurrentScopeObject().SetAttribute(sXSI_NIL,'true'); + nmspcSH := FindAttributeByValueInScope(sXSI_NS); + if IsStrEmpty(nmspcSH) then begin + nmspcSH := 'ns' + IntToStr(NextNameSpaceCounter()); + AddScopeAttribute('xmlns:'+nmspcSH, sXSI_NS); + end else begin + nmspcSH := Copy(nmspcSH,Length('xmlns:')+1,MaxInt); + end; + GetCurrentScopeObject().SetAttribute(nmspcSH + ':' + sNIL,'true'); end; function TSOAPBaseFormatter.IsCurrentScopeNil(): Boolean; Var - s,nsShortName,nilName : string; + s,nsShortName,nilName : shortstring; begin CheckScope(); nsShortName := FindAttributeByValueInScope(sXSI_NS); Result := False; - if not IsStrEmpty(nsShortName) then begin + if IsStrEmpty(nsShortName) then begin + nilName := 'nil'; + end else begin nsShortName := Copy(nsShortName,1 + Pos(':',nsShortName),MaxInt); if not IsStrEmpty(nsShortName) Then nsShortName := nsShortName + ':'; nilName := nsShortName + 'nil'; - s := Trim(GetCurrentScopeObject().GetAttribute(nilName)); - if ( Length(s) > 0 ) and ( AnsiSameText(s,'true') or AnsiSameText(s,'"true"') ) then - Result := True; - end + end; + s := Trim(GetCurrentScopeObject().GetAttribute(nilName)); + if ( Length(s) > 0 ) and ( AnsiSameText(s,'true') or AnsiSameText(s,'"true"') ) then begin + Result := True; + end; end; procedure TSOAPBaseFormatter.BeginScope( @@ -1182,6 +1233,113 @@ begin End; end; +procedure TSOAPBaseFormatter.PutScopeInnerValue( + const ATypeInfo : PTypeInfo; + const AData +); +Var + int64SData : Int64; + int64UData : QWord; + strData : string; + objData : TObject; + boolData : Boolean; + enumData : TEnumIntType; + floatDt : Extended; + dataBuffer : string; + frmt : string; + prcsn,i : Integer; +begin + CheckScope(); + Case ATypeInfo^.Kind Of + tkInt64 : + begin + int64SData := Int64(AData); + dataBuffer := IntToStr(int64SData); + end; + tkQWord : + begin + int64UData := QWord(AData); + dataBuffer := IntToStr(int64UData); + end; + tkLString, tkAString : + begin + strData := string(AData); + dataBuffer := strData; + end; + tkClass : + begin + raise ESOAPException.Create('Inner Scope value must be a "simple type" value.'); + end; + tkBool : + begin + boolData := Boolean(AData); + dataBuffer := BoolToStr(boolData); + end; + tkInteger : + begin + case GetTypeData(ATypeInfo)^.OrdType of + otSByte : enumData := ShortInt(AData); + otUByte : enumData := Byte(AData); + otSWord : enumData := SmallInt(AData); + otUWord : enumData := Word(AData); + otSLong, + otULong : enumData := LongInt(AData); + end; + dataBuffer := IntToStr(enumData); + end; + tkEnumeration : + begin + enumData := 0; + case GetTypeData(ATypeInfo)^.OrdType of + otSByte : enumData := ShortInt(AData); + otUByte : enumData := Byte(AData); + otSWord : enumData := SmallInt(AData); + otUWord : enumData := Word(AData); + otSLong, + otULong : enumData := LongInt(AData); + end; + dataBuffer := GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetExternalPropertyName(GetEnumName(ATypeInfo,enumData)) + end; + tkFloat : + begin + floatDt := 0; + case GetTypeData(ATypeInfo)^.FloatType of + ftSingle : + begin + floatDt := Single(AData); + prcsn := 7; + end; + ftDouble : + begin + floatDt := Double(AData); + prcsn := 15; + end; + ftExtended : + begin + floatDt := Extended(AData); + prcsn := 15; + end; + ftCurr : + begin + floatDt := Currency(AData); + prcsn := 7; + end; + ftComp : + begin + floatDt := Comp(AData); + prcsn := 7; + end; + end; + frmt := '#.' + StringOfChar('#',prcsn) + 'E-0'; + dataBuffer := FormatFloat(frmt,floatDt); + i := Pos(',',dataBuffer); + if ( i > 0 ) then + dataBuffer[i] := '.'; + end; + end; + StackTop().ScopeObject.AppendChild(FDoc.CreateTextNode(dataBuffer)); +end; + procedure TSOAPBaseFormatter.Get( const ATypeInfo : PTypeInfo; var AName : String; @@ -1251,6 +1409,68 @@ begin End; end; +procedure TSOAPBaseFormatter.GetScopeInnerValue( + const ATypeInfo : PTypeInfo; + var AData +); +Var + enumData : TEnumIntType; + floatDt : Extended; + dataBuffer : string; + nd : TDOMNode; +begin + CheckScope(); + nd := StackTop().ScopeObject; + if nd.HasChildNodes() then + dataBuffer := nd.FirstChild.NodeValue + else + dataBuffer := StackTop().ScopeObject.NodeValue; + Case ATypeInfo^.Kind Of + tkInt64 : Int64(AData) := StrToInt64Def(Trim(dataBuffer),0); + tkQWord : QWord(AData) := StrToInt64Def(Trim(dataBuffer),0); + tkLString, + tkAString : string(AData) := dataBuffer; + tkClass : + begin + raise ESOAPException.Create('Inner Scope value must be a "simple type" value.'); + end; + tkBool : + begin + dataBuffer := LowerCase(Trim(dataBuffer)); + if IsStrEmpty(dataBuffer) then + Boolean(AData) := False + else + Boolean(AData) := StrToBool(dataBuffer); + end; + tkInteger, tkEnumeration : + begin + if ( ATypeInfo^.Kind = tkInteger ) then + enumData := StrToIntDef(Trim(dataBuffer),0) + else + enumData := GetEnumValue(ATypeInfo,GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetInternalPropertyName(dataBuffer)); + case GetTypeData(ATypeInfo)^.OrdType of + otSByte : ShortInt(AData) := enumData; + otUByte : Byte(AData) := enumData; + otSWord : SmallInt(AData) := enumData; + otUWord : Word(AData) := enumData; + otSLong, + otULong : LongInt(AData) := enumData; + end; + end; + tkFloat : + begin + floatDt := StrToFloatDef(Trim(dataBuffer),0); + case GetTypeData(ATypeInfo)^.FloatType of + ftSingle : Single(AData) := floatDt; + ftDouble : Double(AData) := floatDt; + ftExtended : Extended(AData) := floatDt; + ftCurr : Currency(AData) := floatDt; + ftComp : Comp(AData) := floatDt; + end; + end; + end; +end; + procedure TSOAPBaseFormatter.SaveToStream(AStream: TStream); begin WriteXMLFile(FDoc,AStream); diff --git a/wst/trunk/doc/WebServiceToolKit.odt b/wst/trunk/doc/WebServiceToolKit.odt index b63291cc2..950a5d183 100644 Binary files a/wst/trunk/doc/WebServiceToolKit.odt and b/wst/trunk/doc/WebServiceToolKit.odt differ diff --git a/wst/trunk/metadata_wsdl.pas b/wst/trunk/metadata_wsdl.pas index 46153930d..3fffd84ed 100644 --- a/wst/trunk/metadata_wsdl.pas +++ b/wst/trunk/metadata_wsdl.pas @@ -670,7 +670,11 @@ begin c := GetEnumNameCount(typItm.DataType); for i := 0 to pred(c) do begin s := Format('%s:%s',[sXSD,sENUMERATION]); - CreateElement(s,restrictNode,AWsdlDocument).SetAttribute(sVALUE,GetEnumName(typItm.DataType,i)); + //CreateElement(s,restrictNode,AWsdlDocument).SetAttribute(sVALUE,GetEnumName(typItm.DataType,i)); + CreateElement(s,restrictNode,AWsdlDocument).SetAttribute( + sVALUE, + typItm.GetExternalPropertyName(GetEnumName(typItm.DataType,i)) + ); end; end; end; diff --git a/wst/trunk/tests/calculator/gui_client/test_calc.lpi b/wst/trunk/tests/calculator/gui_client/test_calc.lpi index c4a075345..df4adbd49 100644 --- a/wst/trunk/tests/calculator/gui_client/test_calc.lpi +++ b/wst/trunk/tests/calculator/gui_client/test_calc.lpi @@ -7,7 +7,7 @@ - + @@ -26,14 +26,14 @@ - + - + @@ -41,10 +41,10 @@ - - + + - + @@ -53,16 +53,16 @@ - + - - - + + + @@ -158,9 +158,11 @@ - - - + + + + + @@ -179,9 +181,11 @@ - - - + + + + + @@ -311,20 +315,81 @@ + + + + + + + + + - + - + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/ebay/test_ebay.lpi b/wst/trunk/tests/ebay/test_ebay.lpi index 97e1757e3..c3f5f9526 100644 --- a/wst/trunk/tests/ebay/test_ebay.lpi +++ b/wst/trunk/tests/ebay/test_ebay.lpi @@ -7,7 +7,7 @@ - + @@ -37,7 +37,7 @@ - + @@ -200,16 +200,7 @@ - - - - - - - - - - + diff --git a/wst/trunk/tests/ebay/test_ebay_gui.lpi b/wst/trunk/tests/ebay/test_ebay_gui.lpi index 9c48ff8e3..a27bdf793 100644 --- a/wst/trunk/tests/ebay/test_ebay_gui.lpi +++ b/wst/trunk/tests/ebay/test_ebay_gui.lpi @@ -7,7 +7,7 @@ - + @@ -26,14 +26,14 @@ - + - + @@ -41,20 +41,20 @@ - - - - + + + + - - - - + + + + @@ -63,7 +63,7 @@ - + @@ -71,63 +71,63 @@ - + - + - - - + + + - - - + + + + + - + - - - - + + - + - + @@ -136,83 +136,252 @@ - - - - + + + + - + - + - + - + - + - + - + - + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + diff --git a/wst/trunk/tests/ebay/umain.lfm b/wst/trunk/tests/ebay/umain.lfm index 00ac18617..0f7db7488 100644 --- a/wst/trunk/tests/ebay/umain.lfm +++ b/wst/trunk/tests/ebay/umain.lfm @@ -15,36 +15,36 @@ object Form1: TForm1 TabOrder = 0 object Label1: TLabel Left = 16 - Height = 14 + Height = 18 Top = 53 - Width = 77 + Width = 98 Caption = 'eBayAuthToken' Color = clNone ParentColor = False end object Label2: TLabel Left = 16 - Height = 14 + Height = 18 Top = 79 - Width = 30 + Width = 37 Caption = 'AppId' Color = clNone ParentColor = False end object Label3: TLabel Left = 16 - Height = 14 + Height = 18 Top = 111 - Width = 30 + Width = 38 Caption = 'DevId' Color = clNone ParentColor = False end object Label4: TLabel Left = 16 - Height = 14 + Height = 18 Top = 144 - Width = 45 + Width = 56 Caption = 'AuthCert' Color = clNone ParentColor = False @@ -115,7 +115,7 @@ object Form1: TForm1 Top = 184 Width = 400 Align = alClient - DefaultItemHeight = 15 + DefaultItemHeight = 19 TabOrder = 1 end end diff --git a/wst/trunk/tests/ebay/umain.lrs b/wst/trunk/tests/ebay/umain.lrs index a2b43944a..d7e60b0ba 100644 --- a/wst/trunk/tests/ebay/umain.lrs +++ b/wst/trunk/tests/ebay/umain.lrs @@ -1,15 +1,17 @@ +{ Ceci est un fichier ressource généré automatiquement par Lazarus } + LazarusResources.Add('TForm1','FORMDATA',[ 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'-'#1#6'Height'#3#132#1#3'Top'#3#159#0#5'W' +'idth'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3#131#1 +#13'ActiveControl'#7#7'Button1'#7'Caption'#6#5'Form1'#8'OnCreate'#7#10'FormC' +'reate'#0#6'TPanel'#6'Panel1'#6'Height'#3#184#0#5'Width'#3#144#1#5'Align'#7#5 - +'alTop'#8'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#14#3 - +'Top'#2'5'#5'Width'#2'M'#7'Caption'#6#13'eBayAuthToken'#5'Color'#7#6'clNone' - +#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6'Height'#2#14#3'Top' - +#2'O'#5'Width'#2#30#7'Caption'#6#5'AppId'#5'Color'#7#6'clNone'#11'ParentColo' - +'r'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2#14#3'Top'#2'o'#5'Widt' - +'h'#2#30#7'Caption'#6#5'DevId'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6 - +'TLabel'#6'Label4'#4'Left'#2#16#6'Height'#2#14#3'Top'#3#144#0#5'Width'#2'-'#7 + +'alTop'#8'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#18#3 + +'Top'#2'5'#5'Width'#2'b'#7'Caption'#6#13'eBayAuthToken'#5'Color'#7#6'clNone' + +#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6'Height'#2#18#3'Top' + +#2'O'#5'Width'#2'%'#7'Caption'#6#5'AppId'#5'Color'#7#6'clNone'#11'ParentColo' + +'r'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2#18#3'Top'#2'o'#5'Widt' + +'h'#2'&'#7'Caption'#6#5'DevId'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6 + +'TLabel'#6'Label4'#4'Left'#2#16#6'Height'#2#18#3'Top'#3#144#0#5'Width'#2'8'#7 +'Caption'#6#8'AuthCert'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6'TBevel' +#6'Bevel1'#4'Left'#2#10#6'Height'#3#170#0#3'Top'#2#4#5'Width'#3'|'#1#7'Ancho' +'rs'#11#5'akTop'#6'akLeft'#7'akRight'#0#0#0#7'TButton'#7'Button1'#4'Left'#3 @@ -27,5 +29,5 @@ LazarusResources.Add('TForm1','FORMDATA',[ +'eft'#2'`'#6'Height'#2#23#3'Top'#3#136#0#5'Width'#3' '#1#7'Anchors'#11#5'akT' +'op'#6'akLeft'#7'akRight'#0#8'TabOrder'#2#5#0#0#0#9'TTreeView'#6'trvOut'#6'H' +'eight'#3#204#0#3'Top'#3#184#0#5'Width'#3#144#1#5'Align'#7#8'alClient'#17'De' - +'faultItemHeight'#2#15#8'TabOrder'#2#1#0#0#0 + +'faultItemHeight'#2#19#8'TabOrder'#2#1#0#0#0 ]); diff --git a/wst/trunk/tests/ebay/umain.pas b/wst/trunk/tests/ebay/umain.pas index 3a6142b70..741d289af 100644 --- a/wst/trunk/tests/ebay/umain.pas +++ b/wst/trunk/tests/ebay/umain.pas @@ -6,7 +6,7 @@ interface uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls, - Buttons, StdCtrls, ComCtrls; + Buttons, StdCtrls, ComCtrls, eBaySvc_intf; type @@ -40,7 +40,8 @@ var implementation uses TypInfo, StrUtils, - httpsend, ssl_openssl, + httpsend, + ssl_openssl, service_intf, soap_formatter, base_service_intf, base_soap_formatter, ebay, ebay_proxy, synapse_http_protocol; diff --git a/wst/trunk/tests/files/CALCULATOR.wsdl b/wst/trunk/tests/files/CALCULATOR.wsdl new file mode 100644 index 000000000..923a08b43 --- /dev/null +++ b/wst/trunk/tests/files/CALCULATOR.wsdl @@ -0,0 +1,147 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wst/trunk/tests/files/metadata_service.wsdl b/wst/trunk/tests/files/metadata_service.wsdl new file mode 100644 index 000000000..bbe923578 --- /dev/null +++ b/wst/trunk/tests/files/metadata_service.wsdl @@ -0,0 +1,214 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wst/trunk/tests/google_api/test_google_api.pas b/wst/trunk/tests/google_api/test_google_api.pas index 38e1d6185..fde450c92 100644 --- a/wst/trunk/tests/google_api/test_google_api.pas +++ b/wst/trunk/tests/google_api/test_google_api.pas @@ -16,7 +16,7 @@ Const sADDRESS = 'http:Address=http://api.google.com/search/beta2'+ ';ProxyServer=10.0.0.5;ProxyPort=8080'; sTARGET = 'urn:GoogleSearch'; - sKEY = '0w9pU3tQFHJyjRUP/bKgv2qwCoXf5pop'; + sKEY = ''; sSERVICE_PROTOCOL = 'SOAP'; Var tmpObj : IGoogleSearch; diff --git a/wst/trunk/tests/http_server/app_object.pas b/wst/trunk/tests/http_server/app_object.pas index 49814fa3f..42e49de75 100644 --- a/wst/trunk/tests/http_server/app_object.pas +++ b/wst/trunk/tests/http_server/app_object.pas @@ -293,8 +293,8 @@ initialization Server_service_RegisterBinaryFormat(); Server_service_RegisterSoapFormat(); - RegisterCalculatorImplementationFactory(); Server_service_RegisterCalculatorService(); + RegisterCalculatorImplementationFactory(); Server_service_RegisterWSTMetadataServiceService(); RegisterWSTMetadataServiceImplementationFactory(); diff --git a/wst/trunk/tests/http_server/wst_http_server.lpi b/wst/trunk/tests/http_server/wst_http_server.lpi index 43d426c29..f5e331308 100644 --- a/wst/trunk/tests/http_server/wst_http_server.lpi +++ b/wst/trunk/tests/http_server/wst_http_server.lpi @@ -12,7 +12,6 @@ - @@ -37,20 +36,16 @@ - - + - - - - + + - @@ -158,13 +153,11 @@ - - @@ -172,12 +165,10 @@ - - @@ -244,12 +235,10 @@ - - @@ -285,9 +274,7 @@ - - @@ -478,17 +465,15 @@ - - + - - - + + @@ -543,9 +528,7 @@ - - diff --git a/wst/trunk/tests/metadata_browser/metadata_browser.lpi b/wst/trunk/tests/metadata_browser/metadata_browser.lpi index a0c3384d9..09f721d46 100644 --- a/wst/trunk/tests/metadata_browser/metadata_browser.lpi +++ b/wst/trunk/tests/metadata_browser/metadata_browser.lpi @@ -7,7 +7,6 @@ - @@ -21,13 +20,10 @@ - + - - - @@ -36,7 +32,7 @@ - + @@ -44,11 +40,9 @@ - - - - - + + + @@ -56,7 +50,7 @@ - + @@ -113,7 +107,7 @@ - + diff --git a/wst/trunk/tests/metadata_browser/metadata_browser.lpr b/wst/trunk/tests/metadata_browser/metadata_browser.lpr index fd235bdfc..ae2101736 100644 --- a/wst/trunk/tests/metadata_browser/metadata_browser.lpr +++ b/wst/trunk/tests/metadata_browser/metadata_browser.lpr @@ -8,7 +8,7 @@ uses {$ENDIF}{$ENDIF} Interfaces, // this includes the LCL widgetset Forms - { add your units here }, umain, metadata_service_proxy, indylaz, + { add your units here }, umain, metadata_service_proxy, metadata_service; begin diff --git a/wst/trunk/tests/metadata_browser/umain.lfm b/wst/trunk/tests/metadata_browser/umain.lfm index 02b9b6087..2cc9fcbca 100644 --- a/wst/trunk/tests/metadata_browser/umain.lfm +++ b/wst/trunk/tests/metadata_browser/umain.lfm @@ -7,14 +7,10 @@ object fMain: TfMain VertScrollBar.Page = 310 ActiveControl = edtAddress Caption = 'WST Metadata Browser' - ClientHeight = 311 - ClientWidth = 574 object pnlHead: TPanel Height = 82 Width = 574 Align = alTop - ClientHeight = 82 - ClientWidth = 574 TabOrder = 0 object Label1: TLabel Left = 14 @@ -89,21 +85,19 @@ object fMain: TfMain Align = alClient BevelInner = bvRaised BevelOuter = bvLowered - ClientHeight = 229 - ClientWidth = 574 TabOrder = 1 object Label2: TLabel Left = 14 - Height = 14 + Height = 18 Top = 14 - Width = 53 + Width = 67 Caption = 'Repository' Color = clNone ParentColor = False end object edtRepositoryList: TComboBox Left = 112 - Height = 21 + Height = 24 Top = 7 Width = 344 Anchors = [akTop, akLeft, akRight] @@ -145,10 +139,12 @@ object fMain: TfMain top = 464 object actGetRepositoryList: TAction Caption = 'Get Rep. List' + DisableIfNoHandler = True OnExecute = actGetRepositoryListExecute end object actGetRepository: TAction Caption = 'Get Repository' + DisableIfNoHandler = True OnExecute = actGetRepositoryExecute OnUpdate = actGetRepositoryUpdate end diff --git a/wst/trunk/tests/metadata_browser/umain.lrs b/wst/trunk/tests/metadata_browser/umain.lrs index 2e2ea5bf5..a865fd84a 100644 --- a/wst/trunk/tests/metadata_browser/umain.lrs +++ b/wst/trunk/tests/metadata_browser/umain.lrs @@ -3,50 +3,49 @@ LazarusResources.Add('TfMain','FORMDATA',[ 'TPF0'#6'TfMain'#5'fMain'#4'Left'#3#175#0#6'Height'#3'7'#1#3'Top'#3#233#0#5'W' +'idth'#3'>'#2#18'HorzScrollBar.Page'#3'='#2#18'VertScrollBar.Page'#3'6'#1#13 - +'ActiveControl'#7#10'edtAddress'#7'Caption'#6#20'WST Metadata Browser'#12'Cl' - +'ientHeight'#3'7'#1#11'ClientWidth'#3'>'#2#0#6'TPanel'#7'pnlHead'#6'Height'#2 - +'R'#5'Width'#3'>'#2#5'Align'#7#5'alTop'#12'ClientHeight'#2'R'#11'ClientWidth' - +#3'>'#2#8'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#14#6'Height'#2#18#3 - +'Top'#2#12#5'Width'#2#26#7'Caption'#6#3'URL'#5'Color'#7#6'clNone'#11'ParentC' - +'olor'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#11#6'Height'#2#18#3'Top'#2'.'#5'W' - +'idth'#2'-'#7'Caption'#6#6'Format'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0 - +#5'TEdit'#10'edtAddress'#4'Left'#2'X'#6'Height'#2#23#3'Top'#2#12#5'Width'#3 - +#224#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#12'Font.CharSet'#7#12'A' - +'NSI_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2#243#9'Font.Name' - +#6#5'Arial'#10'Font.Pitch'#7#10'fpVariable'#8'TabOrder'#2#0#4'Text'#6'6http:' - +'//127.0.0.1:8000/wst/services/IWSTMetadataService'#0#0#7'TButton'#13'btnGet' - +'RepList'#4'Left'#3#221#1#6'Height'#2#25#3'Top'#2'('#5'Width'#2'['#6'Action' - +#7#20'actGetRepositoryList'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpa' - +'cing.InnerBorder'#2#4#8'TabOrder'#2#2#0#0#11'TRadioGroup'#9'edtFormat'#4'Le' - +'ft'#2'X'#6'Height'#2'%'#3'Top'#2'#'#5'Width'#3#24#1#8'AutoFill'#9#7'Caption' - +#6#9' &Format '#28'ChildSizing.LeftRightSpacing'#2#6#28'ChildSizing.TopBotto' - +'mSpacing'#2#6#29'ChildSizing.EnlargeHorizontal'#7#24'crsHomogenousChildResi' - +'ze'#27'ChildSizing.EnlargeVertical'#7#24'crsHomogenousChildResize'#28'Child' - +'Sizing.ShrinkHorizontal'#7#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical' - +#7#14'crsScaleChilds'#18'ChildSizing.Layout'#7#29'cclLeftToRightThenTopToBot' - +'tom'#27'ChildSizing.ControlsPerLine'#2#2#7'Columns'#2#2#9'ItemIndex'#2#0#13 - +'Items.Strings'#1#6#5'&SOAP'#6#7'&binary'#0#8'TabOrder'#2#1#0#0#0#6'TPanel'#9 - +'pnlClient'#6'Height'#3#229#0#3'Top'#2'R'#5'Width'#3'>'#2#5'Align'#7#8'alCli' - +'ent'#10'BevelInner'#7#8'bvRaised'#10'BevelOuter'#7#9'bvLowered'#12'ClientHe' - +'ight'#3#229#0#11'ClientWidth'#3'>'#2#8'TabOrder'#2#1#0#6'TLabel'#6'Label2'#4 - +'Left'#2#14#6'Height'#2#14#3'Top'#2#14#5'Width'#2'5'#7'Caption'#6#10'Reposit' - +'ory'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#9'TComboBox'#17'edtReposito' - +'ryList'#4'Left'#2'p'#6'Height'#2#21#3'Top'#2#7#5'Width'#3'X'#1#7'Anchors'#11 - +#5'akTop'#6'akLeft'#7'akRight'#0#16'AutoCompleteText'#11#22'cbactEndOfLineCo' - +'mplete'#20'cbactSearchAscending'#0#9'MaxLength'#2#0#8'TabOrder'#2#0#4'Text' - +#6#17'edtRepositoryList'#0#0#9'TTreeView'#11'tvwMetadata'#4'Left'#2#11#6'Hei' - +'ght'#3#176#0#3'Top'#2'&'#5'Width'#3'+'#2#7'Anchors'#11#5'akTop'#6'akLeft'#7 - +'akRight'#8'akBottom'#0#17'DefaultItemHeight'#2#18#12'Font.CharSet'#7#12'ANS' - +'I_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2#243#9'Font.Name'#6 - +#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#8'ReadOnly'#9#8'TabOrder'#2#1#7 - +'Options'#11#17'tvoAutoItemHeight'#16'tvoHideSelection'#21'tvoKeepCollapsedN' - +'odes'#11'tvoReadOnly'#14'tvoShowButtons'#12'tvoShowLines'#11'tvoShowRoot'#17 - +'tvoShowSeparators'#11'tvoToolTips'#0#13'TreeLineColor'#7#6'clNavy'#0#0#7'TB' - +'utton'#7'Button1'#4'Left'#3#221#1#6'Height'#2#25#3'Top'#2#6#5'Width'#2'['#6 - +'Action'#7#16'actGetRepository'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'Borde' - +'rSpacing.InnerBorder'#2#4#8'TabOrder'#2#2#0#0#0#11'TActionList'#2'AL'#4'lef' - +'t'#2'H'#3'top'#3#208#1#0#7'TAction'#20'actGetRepositoryList'#7'Caption'#6#13 - +'Get Rep. List'#9'OnExecute'#7#27'actGetRepositoryListExecute'#0#0#7'TAction' - +#16'actGetRepository'#7'Caption'#6#14'Get Repository'#9'OnExecute'#7#23'actG' - +'etRepositoryExecute'#8'OnUpdate'#7#22'actGetRepositoryUpdate'#0#0#0#0 + +'ActiveControl'#7#10'edtAddress'#7'Caption'#6#20'WST Metadata Browser'#0#6'T' + +'Panel'#7'pnlHead'#6'Height'#2'R'#5'Width'#3'>'#2#5'Align'#7#5'alTop'#8'TabO' + +'rder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2#14#6'Height'#2#18#3'Top'#2#12#5'W' + +'idth'#2#26#7'Caption'#6#3'URL'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#6 + +'TLabel'#6'Label3'#4'Left'#2#11#6'Height'#2#18#3'Top'#2'.'#5'Width'#2'-'#7'C' + +'aption'#6#6'Format'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#5'TEdit'#10 + +'edtAddress'#4'Left'#2'X'#6'Height'#2#23#3'Top'#2#12#5'Width'#3#224#1#7'Anch' + +'ors'#11#5'akTop'#6'akLeft'#7'akRight'#0#12'Font.CharSet'#7#12'ANSI_CHARSET' + +#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2#243#9'Font.Name'#6#5'Arial'#10 + +'Font.Pitch'#7#10'fpVariable'#8'TabOrder'#2#0#4'Text'#6'6http://127.0.0.1:80' + +'00/wst/services/IWSTMetadataService'#0#0#7'TButton'#13'btnGetRepList'#4'Lef' + +'t'#3#221#1#6'Height'#2#25#3'Top'#2'('#5'Width'#2'['#6'Action'#7#20'actGetRe' + +'positoryList'#7'Anchors'#11#5'akTop'#7'akRight'#0#25'BorderSpacing.InnerBor' + +'der'#2#4#8'TabOrder'#2#2#0#0#11'TRadioGroup'#9'edtFormat'#4'Left'#2'X'#6'He' + +'ight'#2'%'#3'Top'#2'#'#5'Width'#3#24#1#8'AutoFill'#9#7'Caption'#6#9' &Forma' + +'t '#28'ChildSizing.LeftRightSpacing'#2#6#28'ChildSizing.TopBottomSpacing'#2 + +#6#29'ChildSizing.EnlargeHorizontal'#7#24'crsHomogenousChildResize'#27'Child' + +'Sizing.EnlargeVertical'#7#24'crsHomogenousChildResize'#28'ChildSizing.Shrin' + +'kHorizontal'#7#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsSc' + +'aleChilds'#18'ChildSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'Ch' + +'ildSizing.ControlsPerLine'#2#2#7'Columns'#2#2#9'ItemIndex'#2#0#13'Items.Str' + +'ings'#1#6#5'&SOAP'#6#7'&binary'#0#8'TabOrder'#2#1#0#0#0#6'TPanel'#9'pnlClie' + +'nt'#6'Height'#3#229#0#3'Top'#2'R'#5'Width'#3'>'#2#5'Align'#7#8'alClient'#10 + +'BevelInner'#7#8'bvRaised'#10'BevelOuter'#7#9'bvLowered'#8'TabOrder'#2#1#0#6 + +'TLabel'#6'Label2'#4'Left'#2#14#6'Height'#2#18#3'Top'#2#14#5'Width'#2'C'#7'C' + +'aption'#6#10'Repository'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#9'TComb' + +'oBox'#17'edtRepositoryList'#4'Left'#2'p'#6'Height'#2#24#3'Top'#2#7#5'Width' + +#3'X'#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#0#16'AutoCompleteText'#11 + +#22'cbactEndOfLineComplete'#20'cbactSearchAscending'#0#9'MaxLength'#2#0#8'Ta' + +'bOrder'#2#0#4'Text'#6#17'edtRepositoryList'#0#0#9'TTreeView'#11'tvwMetadata' + +#4'Left'#2#11#6'Height'#3#176#0#3'Top'#2'&'#5'Width'#3'+'#2#7'Anchors'#11#5 + +'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#17'DefaultItemHeight'#2#18#12'Fon' + +'t.CharSet'#7#12'ANSI_CHARSET'#10'Font.Color'#7#7'clBlack'#11'Font.Height'#2 + +#243#9'Font.Name'#6#11'Courier New'#10'Font.Pitch'#7#7'fpFixed'#8'ReadOnly'#9 + +#8'TabOrder'#2#1#7'Options'#11#17'tvoAutoItemHeight'#16'tvoHideSelection'#21 + +'tvoKeepCollapsedNodes'#11'tvoReadOnly'#14'tvoShowButtons'#12'tvoShowLines' + +#11'tvoShowRoot'#17'tvoShowSeparators'#11'tvoToolTips'#0#13'TreeLineColor'#7 + +#6'clNavy'#0#0#7'TButton'#7'Button1'#4'Left'#3#221#1#6'Height'#2#25#3'Top'#2 + +#6#5'Width'#2'['#6'Action'#7#16'actGetRepository'#7'Anchors'#11#5'akTop'#7'a' + +'kRight'#0#25'BorderSpacing.InnerBorder'#2#4#8'TabOrder'#2#2#0#0#0#11'TActio' + +'nList'#2'AL'#4'left'#2'H'#3'top'#3#208#1#0#7'TAction'#20'actGetRepositoryLi' + +'st'#7'Caption'#6#13'Get Rep. List'#18'DisableIfNoHandler'#9#9'OnExecute'#7 + +#27'actGetRepositoryListExecute'#0#0#7'TAction'#16'actGetRepository'#7'Capti' + +'on'#6#14'Get Repository'#18'DisableIfNoHandler'#9#9'OnExecute'#7#23'actGetR' + +'epositoryExecute'#8'OnUpdate'#7#22'actGetRepositoryUpdate'#0#0#0#0 ]); diff --git a/wst/trunk/tests/metadata_browser/umain.pas b/wst/trunk/tests/metadata_browser/umain.pas index 7c4af5ffc..89f941d08 100644 --- a/wst/trunk/tests/metadata_browser/umain.pas +++ b/wst/trunk/tests/metadata_browser/umain.pas @@ -44,7 +44,7 @@ implementation uses base_service_intf, service_intf, soap_formatter, binary_formatter, synapse_http_protocol, //indy_http_protocol, ics_http_protocol, - //ics_tcp_protocol, + ics_tcp_protocol, library_protocol, metadata_service_proxy; @@ -94,7 +94,7 @@ begin Result := TWSTMetadataService_Proxy.Create( 'WSTMetadataService', s, - Format('http:Address=%s',[edtAddress.Text]) + edtAddress.Text//Format('http:Address=%s',[edtAddress.Text]) ) as IWSTMetadataService; //lib:FileName=C:\Programmes\lazarus\wst\tests\library\obj\lib_server.dll;target=IWSTMetadataService //'http:Address=http://127.0.0.1:8000/services/IWSTMetadataService' @@ -163,6 +163,7 @@ initialization RegisterStdTypes(); SYNAPSE_RegisterHTTP_Transport(); LIB_Register_Transport(); + ICS_RegisterTCP_Transport(); //ICS_RegisterHTTP_Transport(); //INDY_RegisterHTTP_Transport(); end. diff --git a/wst/trunk/tests/tcp_server/tcp_gui_server.lpi b/wst/trunk/tests/tcp_server/tcp_gui_server.lpi index 5b3c1c137..32590d2ab 100644 --- a/wst/trunk/tests/tcp_server/tcp_gui_server.lpi +++ b/wst/trunk/tests/tcp_server/tcp_gui_server.lpi @@ -7,7 +7,7 @@ - + @@ -26,15 +26,15 @@ - + - + - - + + @@ -43,20 +43,20 @@ - - + + - + - - - - + + + + @@ -235,16 +235,18 @@ - - + + - - - + + + + + @@ -293,8 +295,8 @@ - - + + @@ -303,8 +305,8 @@ - - + + @@ -313,18 +315,81 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/tcp_server/umain.lfm b/wst/trunk/tests/tcp_server/umain.lfm index 1a1e9b16b..75c12aec5 100644 --- a/wst/trunk/tests/tcp_server/umain.lfm +++ b/wst/trunk/tests/tcp_server/umain.lfm @@ -7,15 +7,12 @@ object fMain: TfMain VertScrollBar.Page = 299 ActiveControl = Button1 Caption = 'Simple TCP App Server' - ClientHeight = 300 - ClientWidth = 400 OnCreate = FormCreate - PixelsPerInch = 96 object Label1: TLabel Left = 16 - Height = 14 + Height = 18 Top = 72 - Width = 18 + Width = 24 Caption = 'Log' Color = clNone ParentColor = False @@ -26,7 +23,6 @@ object fMain: TfMain Top = 8 Width = 104 Action = actStart - BorderSpacing.InnerBorder = 2 TabOrder = 0 end object mmoLog: TMemo @@ -45,7 +41,6 @@ object fMain: TfMain Top = 40 Width = 104 Action = actStop - BorderSpacing.InnerBorder = 2 TabOrder = 2 end object edtPort: TEdit @@ -61,16 +56,19 @@ object fMain: TfMain top = 32 object actStart: TAction Caption = 'Start( Port=)' + DisableIfNoHandler = True OnExecute = actStartExecute OnUpdate = actStartUpdate end object actStop: TAction Caption = 'Stop' + DisableIfNoHandler = True OnExecute = actStopExecute OnUpdate = actStopUpdate end object actClearLog: TAction Caption = 'Clear Log' + DisableIfNoHandler = True OnExecute = actClearLogExecute end end diff --git a/wst/trunk/tests/tcp_server/umain.lrs b/wst/trunk/tests/tcp_server/umain.lrs index 5910ad7aa..8f3a0ece6 100644 --- a/wst/trunk/tests/tcp_server/umain.lrs +++ b/wst/trunk/tests/tcp_server/umain.lrs @@ -3,22 +3,21 @@ LazarusResources.Add('TfMain','FORMDATA',[ 'TPF0'#6'TfMain'#5'fMain'#4'Left'#3'"'#1#6'Height'#3','#1#3'Top'#3#180#0#5'Wi' +'dth'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3'+'#1#13 - +'ActiveControl'#7#7'Button1'#7'Caption'#6#21'Simple TCP App Server'#12'Clien' - +'tHeight'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'#13'Pix' - +'elsPerInch'#2'`'#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#14#3'Top'#2 - +'H'#5'Width'#2#18#7'Caption'#6#3'Log'#5'Color'#7#6'clNone'#11'ParentColor'#8 - +#0#0#7'TButton'#7'Button1'#4'Left'#2#16#6'Height'#2#25#3'Top'#2#8#5'Width'#2 - +'h'#6'Action'#7#8'actStart'#25'BorderSpacing.InnerBorder'#2#2#8'TabOrder'#2#0 - +#0#0#5'TMemo'#6'mmoLog'#4'Left'#2#8#6'Height'#3#192#0#3'Top'#2'`'#5'Width'#3 - +#128#1#7'Anchors'#11#5'akTop'#6'akLeft'#7'akRight'#8'akBottom'#0#8'ReadOnly' - +#9#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#1#0#0#7'TButton'#7'Button2' - +#4'Left'#2#16#6'Height'#2#25#3'Top'#2'('#5'Width'#2'h'#6'Action'#7#7'actStop' - +#25'BorderSpacing.InnerBorder'#2#2#8'TabOrder'#2#2#0#0#5'TEdit'#7'edtPort'#4 - +'Left'#3#128#0#6'Height'#2#23#3'Top'#2#10#5'Width'#2'P'#8'TabOrder'#2#3#4'Te' - +'xt'#6#4'1234'#0#0#11'TActionList'#2'AL'#4'left'#3#152#0#3'top'#2' '#0#7'TAc' - +'tion'#8'actStart'#7'Caption'#6#13'Start( Port=)'#9'OnExecute'#7#15'actStart' - +'Execute'#8'OnUpdate'#7#14'actStartUpdate'#0#0#7'TAction'#7'actStop'#7'Capti' - +'on'#6#4'Stop'#9'OnExecute'#7#14'actStopExecute'#8'OnUpdate'#7#13'actStopUpd' - +'ate'#0#0#7'TAction'#11'actClearLog'#7'Caption'#6#9'Clear Log'#9'OnExecute'#7 - +#18'actClearLogExecute'#0#0#0#0 + +'ActiveControl'#7#7'Button1'#7'Caption'#6#21'Simple TCP App Server'#8'OnCrea' + +'te'#7#10'FormCreate'#0#6'TLabel'#6'Label1'#4'Left'#2#16#6'Height'#2#18#3'To' + +'p'#2'H'#5'Width'#2#24#7'Caption'#6#3'Log'#5'Color'#7#6'clNone'#11'ParentCol' + +'or'#8#0#0#7'TButton'#7'Button1'#4'Left'#2#16#6'Height'#2#25#3'Top'#2#8#5'Wi' + +'dth'#2'h'#6'Action'#7#8'actStart'#8'TabOrder'#2#0#0#0#5'TMemo'#6'mmoLog'#4 + +'Left'#2#8#6'Height'#3#192#0#3'Top'#2'`'#5'Width'#3#128#1#7'Anchors'#11#5'ak' + +'Top'#6'akLeft'#7'akRight'#8'akBottom'#0#8'ReadOnly'#9#10'ScrollBars'#7#10's' + +'sAutoBoth'#8'TabOrder'#2#1#0#0#7'TButton'#7'Button2'#4'Left'#2#16#6'Height' + +#2#25#3'Top'#2'('#5'Width'#2'h'#6'Action'#7#7'actStop'#8'TabOrder'#2#2#0#0#5 + +'TEdit'#7'edtPort'#4'Left'#3#128#0#6'Height'#2#23#3'Top'#2#10#5'Width'#2'P'#8 + +'TabOrder'#2#3#4'Text'#6#4'1234'#0#0#11'TActionList'#2'AL'#4'left'#3#152#0#3 + +'top'#2' '#0#7'TAction'#8'actStart'#7'Caption'#6#13'Start( Port=)'#18'Disabl' + +'eIfNoHandler'#9#9'OnExecute'#7#15'actStartExecute'#8'OnUpdate'#7#14'actStar' + +'tUpdate'#0#0#7'TAction'#7'actStop'#7'Caption'#6#4'Stop'#18'DisableIfNoHandl' + +'er'#9#9'OnExecute'#7#14'actStopExecute'#8'OnUpdate'#7#13'actStopUpdate'#0#0 + +#7'TAction'#11'actClearLog'#7'Caption'#6#9'Clear Log'#18'DisableIfNoHandler' + +#9#9'OnExecute'#7#18'actClearLogExecute'#0#0#0#0 ]); diff --git a/wst/trunk/tests/tcp_server/umain.pas b/wst/trunk/tests/tcp_server/umain.pas index e42cd76b7..430cc5807 100644 --- a/wst/trunk/tests/tcp_server/umain.pas +++ b/wst/trunk/tests/tcp_server/umain.pas @@ -39,7 +39,8 @@ var implementation uses server_unit, server_service_soap, server_binary_formatter, - calculator, calculator_imp, calculator_binder; + calculator, calculator_imp, calculator_binder, + metadata_service, metadata_service_imp, metadata_service_binder; Var scktServer : TTcpSrvApp; @@ -84,6 +85,9 @@ begin RegisterCalculatorImplementationFactory(); Server_service_RegisterSoapFormat(); Server_service_RegisterBinaryFormat(); + + RegisterWSTMetadataServiceImplementationFactory(); + Server_service_RegisterWSTMetadataServiceService end; procedure TfMain.LogMessage(const AMsg: string); @@ -95,4 +99,3 @@ initialization {$I umain.lrs} end. - diff --git a/wst/trunk/tests/test_suite/test_parserdef.pas b/wst/trunk/tests/test_suite/test_parserdef.pas new file mode 100644 index 000000000..ec11768c4 --- /dev/null +++ b/wst/trunk/tests/test_suite/test_parserdef.pas @@ -0,0 +1,109 @@ +unit test_parserdef; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, parserdefs, fpcunit, testregistry; + +type + + { TTest_TClassTypeDefinition } + + TTest_TClassTypeDefinition = class(TTestCase) + published + procedure IsDescendantOf(); + procedure SetParent(); + end; + +implementation + +{ TTest_TClassTypeDefinition } + +procedure TTest_TClassTypeDefinition.IsDescendantOf(); +var + a, b , c, d : TClassTypeDefinition; +begin + a := nil; + b := nil; + c := nil; + d := nil; + try + a := TClassTypeDefinition.Create('a'); + + b := TClassTypeDefinition.Create('b'); + b.SetParent(a); + + c := TClassTypeDefinition.Create('c'); + c.SetParent(b); + + d := TClassTypeDefinition.Create('d'); + + AssertTrue('b IsDescendantOf a',b.IsDescendantOf(a)); + AssertTrue('c IsDescendantOf b',c.IsDescendantOf(b)); + AssertTrue('c IsDescendantOf a',c.IsDescendantOf(a)); + + AssertFalse('b IsDescendantOf c',b.IsDescendantOf(c)); + AssertFalse('a IsDescendantOf b',a.IsDescendantOf(b)); + AssertFalse('a IsDescendantOf c',a.IsDescendantOf(c)); + + AssertFalse('d IsDescendantOf a',d.IsDescendantOf(a)); + + finally + FreeAndNil(d); + FreeAndNil(c); + FreeAndNil(b); + FreeAndNil(a); + end; +end; + +procedure TTest_TClassTypeDefinition.SetParent(); +var + a, b , c, d : TClassTypeDefinition; + excp : Boolean; +begin + a := nil; + b := nil; + c := nil; + d := nil; + try + a := TClassTypeDefinition.Create('a'); + + b := TClassTypeDefinition.Create('b'); + b.SetParent(a); + + c := TClassTypeDefinition.Create('c'); + c.SetParent(b); + + d := TClassTypeDefinition.Create('d'); + + excp := False;; + try + c.SetParent(c); + except + excp := True; + end; + if not excp then begin + Fail('c.SetParent(c);'); + end; + + AssertSame('a.Parent = nil',nil,a.Parent); + AssertSame('b.Parent = a',a,b.Parent); + AssertSame('c.Parent = b',b,c.Parent); + AssertSame('d.Parent = nil',nil,d.Parent); + + finally + FreeAndNil(d); + FreeAndNil(c); + FreeAndNil(b); + FreeAndNil(a); + end; + +end; + +initialization + RegisterTest(TTest_TClassTypeDefinition); + +end. + diff --git a/wst/trunk/tests/test_suite/testformatter_unit.pas b/wst/trunk/tests/test_suite/testformatter_unit.pas index e51d63b82..f35f3292e 100644 --- a/wst/trunk/tests/test_suite/testformatter_unit.pas +++ b/wst/trunk/tests/test_suite/testformatter_unit.pas @@ -87,6 +87,168 @@ type property Val_64S : Int64 Read FVal_64S Write FVal_64S; End; + T_ComplexInt64SContent = class(TComplexInt64SContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt64UContent = class(TComplexInt64UContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + { T_ComplexInt32SContent } + + T_ComplexInt32SContent = class(TComplexInt32SContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt32UContent = class(TComplexInt32UContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt16SContent = class(TComplexInt16SContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt16UContent = class(TComplexInt16UContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt8SContent = class(TComplexInt8SContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexInt8UContent = class(TComplexInt8UContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexFloatExtendedContent = class(TComplexFloatExtendedContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexFloatDoubleContent = class(TComplexFloatDoubleContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + T_ComplexStringContent = class(TComplexStringContentRemotable) + private + FBoolSimpleAtt_Exemple: Boolean; + FIntSimpleAtt_Exemple: Integer; + FStrSimpleAtt_Exemple: string; + published + property StrSimpleAtt_Exemple : string read FStrSimpleAtt_Exemple write FStrSimpleAtt_Exemple; + property IntSimpleAtt_Exemple : Integer read FIntSimpleAtt_Exemple write FIntSimpleAtt_Exemple; + property BoolSimpleAtt_Exemple : Boolean read FBoolSimpleAtt_Exemple write FBoolSimpleAtt_Exemple; + end; + + { TClass_CplxSimpleContent } + + TClass_CplxSimpleContent = class(TBaseComplexRemotable) + private + FElt_Exemple: string; + FVal_CplxDouble: T_ComplexFloatDoubleContent; + FVal_CplxInt16S: T_ComplexInt16SContent; + FVal_CplxInt16U: T_ComplexInt16UContent; + FVal_CplxInt32S: T_ComplexInt32SContent; + FVal_CplxInt32U: T_ComplexInt32UContent; + FVal_CplxExtended : T_ComplexFloatExtendedContent; + FVal_CplxInt64S: T_ComplexInt64SContent; + FVal_CplxInt64U: T_ComplexInt64UContent; + FVal_CplxInt8S: T_ComplexInt8SContent; + FVal_CplxInt8U: T_ComplexInt8UContent; + FVal_CplxString: T_ComplexStringContent; + public + constructor Create();override; + destructor Destroy();override; + published + property Val_CplxInt64S : T_ComplexInt64SContent read FVal_CplxInt64S write FVal_CplxInt64S; + property Val_CplxInt64U : T_ComplexInt64UContent read FVal_CplxInt64U write FVal_CplxInt64U; + + property Val_CplxInt32S : T_ComplexInt32SContent read FVal_CplxInt32S write FVal_CplxInt32S; + property Val_CplxInt32U : T_ComplexInt32UContent read FVal_CplxInt32U write FVal_CplxInt32U; + + property Val_CplxInt16U : T_ComplexInt16UContent read FVal_CplxInt16U write FVal_CplxInt16U; + property Val_CplxInt16S : T_ComplexInt16SContent read FVal_CplxInt16S write FVal_CplxInt16S; + + property Val_CplxInt8U : T_ComplexInt8UContent read FVal_CplxInt8U write FVal_CplxInt8U; + property Val_CplxInt8S : T_ComplexInt8SContent read FVal_CplxInt8S write FVal_CplxInt8S; + + property Val_CplxExtended : T_ComplexFloatExtendedContent read FVal_CplxExtended write FVal_CplxExtended; + property Val_CplxDouble : T_ComplexFloatDoubleContent read FVal_CplxDouble write FVal_CplxDouble; + property Val_CplxString : T_ComplexStringContent read FVal_CplxString write FVal_CplxString; + + property Elt_Exemple : string read FElt_Exemple write FElt_Exemple; + end; + { TClass_Enum } TClass_Enum = class(TBaseComplexRemotable) @@ -115,29 +277,46 @@ type property Val_Currency : Currency Read FVal_Currency Write FVal_Currency; End; - { TTestFormatter } + { TTestFormatterSimpleType } - TTestFormatter= class(TTestCase) + TTestFormatterSimpleType= class(TTestCase) protected function CreateFormatter(ARootType : PTypeInfo):IFormatterBase;virtual;abstract; published procedure Test_Int_8; + procedure Test_Int_8_ScopeData; procedure Test_Int_16; procedure Test_Int_32; procedure Test_Int_64; - procedure Test_Int_WithClass; - + procedure Test_Single_4; procedure Test_Double_8; procedure Test_Currency_8; procedure Test_Extended_10; - procedure Test_Float_WithClass; procedure Test_String; procedure Test_Bool; procedure Test_Enum; + end; + + { TTestFormatter } + + TTestFormatter= class(TTestFormatterSimpleType) + published + procedure Test_Int_WithClass; + + procedure Test_Float_WithClass; + procedure Test_Enum_Bool_String_WithClass; + procedure Test_CplxInt64SimpleContent_WithClass; + procedure Test_CplxInt32SimpleContent_WithClass; + procedure Test_CplxInt16SimpleContent_WithClass; + procedure Test_CplxInt8SimpleContent_WithClass; + + procedure Test_CplxFloatExtendedSimpleContent_WithClass; + procedure Test_CplxStringSimpleContent_WithClass; + procedure Test_Object(); procedure Test_Object_Nil(); procedure Test_StringArray(); @@ -160,6 +339,8 @@ type procedure Test_FloatDoubleArray(); procedure Test_FloatExtendedArray(); procedure Test_FloatCurrencyArray(); + + procedure Test_ComplexInt32S(); end; { TTestBinaryFormatter } @@ -171,7 +352,7 @@ type { TTestBinaryFormatterAttributes } - TTestBinaryFormatterAttributes= class(TTestBinaryFormatter) + TTestBinaryFormatterAttributes= class(TTestFormatterSimpleType) protected function CreateFormatter(ARootType : PTypeInfo):IFormatterBase;override; end; @@ -185,7 +366,7 @@ type { TTestSOAPFormatterAttributes } - TTestSOAPFormatterAttributes = class(TTestSOAPFormatter) + TTestSOAPFormatterAttributes = class(TTestFormatterSimpleType) protected function CreateFormatter(ARootType : PTypeInfo):IFormatterBase;override; end; @@ -222,10 +403,26 @@ type procedure Test_Assign(); end; + { TTest_TDateRemotable } + + TTest_TDateRemotable = class(TTestCase) + published + procedure FormatDate(); + procedure ParseDate(); + end; + + { TTest_TDurationRemotable } + + TTest_TDurationRemotable = class(TTestCase) + published + procedure FormatDate(); + procedure ParseDate(); + end; + implementation uses base_binary_formatter, base_soap_formatter; -procedure TTestFormatter.Test_Int_8; +procedure TTestFormatterSimpleType.Test_Int_8; const VAL_1 = 12; VAL_2 = -10; Var f : IFormatterBase; @@ -267,7 +464,59 @@ begin End; end; -procedure TTestFormatter.Test_Int_16; +procedure TTestFormatterSimpleType.Test_Int_8_ScopeData; +const VAL_1 = 12; VAL_2 = -10; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + intVal_U : Byte; intVal_S : ShortInt; +begin + s := Nil; + Try + intVal_U := VAL_1; + f := CreateFormatter(TypeInfo(TClass_Int)); + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.PutScopeInnerValue(TypeInfo(Byte),intVal_U); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + intVal_U := 0; + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + f.GetScopeInnerValue(TypeInfo(Byte),intVal_U); + f.EndScopeRead(); + AssertEquals(VAL_1,intVal_U); + /// + intVal_S := VAL_2; + f := CreateFormatter(TypeInfo(TClass_Int)); + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.PutScopeInnerValue(TypeInfo(ShortInt),intVal_S); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + intVal_S := 0; + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + f.GetScopeInnerValue(TypeInfo(ShortInt),intVal_S); + f.EndScopeRead(); + AssertEquals(VAL_2,intVal_S); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Int_16; const VAL_1 = 1210; VAL_2 : SmallInt = -1012; Var f : IFormatterBase; @@ -309,7 +558,7 @@ begin End; end; -procedure TTestFormatter.Test_Int_32; +procedure TTestFormatterSimpleType.Test_Int_32; const VAL_1 = 121076; VAL_2 : LongInt = -101276; Var f : IFormatterBase; @@ -351,7 +600,7 @@ begin End; end; -procedure TTestFormatter.Test_Int_64; +procedure TTestFormatterSimpleType.Test_Int_64; const VAL_1 = 121076; VAL_2 : Int64 = -101276; Var f : IFormatterBase; @@ -393,6 +642,276 @@ begin End; end; +procedure TTestFormatterSimpleType.Test_Single_4; +const VAL_1 = 12.10; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + tmpVal : Single; +begin + s := Nil; + Try + tmpVal := VAL_1; + f := CreateFormatter(TypeInfo(TClass_Float)); + + f.BeginObject('Root',TypeInfo(TClass_Float)); + f.Put('tmpVal',TypeInfo(Single),tmpVal); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + tmpVal := 0; + + f := CreateFormatter(TypeInfo(TClass_Float)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); + x := 'tmpVal'; + f.Get(TypeInfo(Single),x,tmpVal); + f.EndScopeRead(); + + AssertEquals(VAL_1,tmpVal); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Double_8; +const VAL_1 = 12.10; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + tmpVal : Double; +begin + s := Nil; + Try + tmpVal := VAL_1; + f := CreateFormatter(TypeInfo(TClass_Float)); + + f.BeginObject('Root',TypeInfo(TClass_Float)); + f.Put('tmpVal',TypeInfo(Double),tmpVal); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + tmpVal := 0; + + f := CreateFormatter(TypeInfo(TClass_Float)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); + x := 'tmpVal'; + f.Get(TypeInfo(Double),x,tmpVal); + f.EndScopeRead(); + + AssertEquals(VAL_1,tmpVal); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Currency_8; +const VAL_1 = 12.10; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + tmpVal : Currency; +begin + s := Nil; + Try + tmpVal := VAL_1; + f := CreateFormatter(TypeInfo(TClass_Float)); + + f.BeginObject('Root',TypeInfo(TClass_Float)); + f.Put('tmpVal',TypeInfo(Currency),tmpVal); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + tmpVal := 0; + + f := CreateFormatter(TypeInfo(TClass_Float)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); + x := 'tmpVal'; + f.Get(TypeInfo(Currency),x,tmpVal); + f.EndScopeRead(); + + AssertEquals(VAL_1,tmpVal); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Extended_10; +const VAL_1 = 12.10; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + tmpVal : Extended; +begin + s := Nil; + Try + tmpVal := VAL_1; + f := CreateFormatter(TypeInfo(TClass_Float)); + + f.BeginObject('Root',TypeInfo(TClass_Float)); + f.Put('tmpVal',TypeInfo(Extended),tmpVal); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + tmpVal := 0; + + f := CreateFormatter(TypeInfo(TClass_Float)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); + x := 'tmpVal'; + f.Get(TypeInfo(Extended),x,tmpVal); + f.EndScopeRead(); + + AssertEquals(VAL_1,tmpVal); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_String; +const VAL_1 = 'AzErTy'; VAL_2 = 'QwErTy'; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + intVal_1 : string; intVal_3 : string; +begin + s := Nil; + Try + intVal_1 := VAL_1; + intVal_3 := VAL_2; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('intVal_1',TypeInfo(string),intVal_1); + f.Put('intVal_3',TypeInfo(string),intVal_3); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + intVal_1 := ''; + intVal_3 := 'yyyyyyyy'; + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'intVal_1'; + f.Get(TypeInfo(string),x,intVal_1); + x := 'intVal_3'; + f.Get(TypeInfo(string),x,intVal_3); + f.EndScopeRead(); + + AssertEquals(VAL_1,intVal_1); + AssertEquals(VAL_2,intVal_3); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Bool; +const VAL_1 = True; VAL_2 = False; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + intVal_1 : Boolean; intVal_3 : Boolean; +begin + s := Nil; + Try + intVal_1 := VAL_1; + intVal_3 := VAL_2; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('intVal_1',TypeInfo(Boolean),intVal_1); + f.Put('intVal_3',TypeInfo(Boolean),intVal_3); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + intVal_1 := False; + intVal_3 := True; + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'intVal_1'; + f.Get(TypeInfo(Boolean),x,intVal_1); + x := 'intVal_3'; + f.Get(TypeInfo(Boolean),x,intVal_3); + f.EndScopeRead(); + + AssertEquals(VAL_1,intVal_1); + AssertEquals(VAL_2,intVal_3); + Finally + s.Free(); + End; +end; + +procedure TTestFormatterSimpleType.Test_Enum; +const VAL_1 = teTwo; VAL_2 = teFour; +Var + f : IFormatterBase; + s : TMemoryStream; + x : string; + intVal_1 : TTestEnum; intVal_3 : TTestEnum; +begin + s := Nil; + Try + intVal_1 := VAL_1; + intVal_3 := VAL_2; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Enum)); + f.Put('intVal_1',TypeInfo(TTestEnum),intVal_1); + f.Put('intVal_3',TypeInfo(TTestEnum),intVal_3); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + intVal_1 := teOne; + intVal_3 := teOne; + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'intVal_1'; + f.Get(TypeInfo(TTestEnum),x,intVal_1); + x := 'intVal_3'; + f.Get(TypeInfo(TTestEnum),x,intVal_3); + f.EndScopeRead(); + + AssertEquals(Ord(VAL_1),Ord(intVal_1)); + AssertEquals(Ord(VAL_2),Ord(intVal_3)); + Finally + s.Free(); + End; +end; + procedure TTestFormatter.Test_Int_WithClass; Var f : IFormatterBase; @@ -446,150 +965,6 @@ begin End; end; -procedure TTestFormatter.Test_Single_4; -const VAL_1 = 12.10; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - tmpVal : Single; -begin - s := Nil; - Try - tmpVal := VAL_1; - f := CreateFormatter(TypeInfo(TClass_Float)); - - f.BeginObject('Root',TypeInfo(TClass_Float)); - f.Put('tmpVal',TypeInfo(Single),tmpVal); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - tmpVal := 0; - - f := CreateFormatter(TypeInfo(TClass_Float)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); - x := 'tmpVal'; - f.Get(TypeInfo(Single),x,tmpVal); - f.EndScopeRead(); - - AssertEquals(VAL_1,tmpVal); - Finally - s.Free(); - End; -end; - -procedure TTestFormatter.Test_Double_8; -const VAL_1 = 12.10; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - tmpVal : Double; -begin - s := Nil; - Try - tmpVal := VAL_1; - f := CreateFormatter(TypeInfo(TClass_Float)); - - f.BeginObject('Root',TypeInfo(TClass_Float)); - f.Put('tmpVal',TypeInfo(Double),tmpVal); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - tmpVal := 0; - - f := CreateFormatter(TypeInfo(TClass_Float)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); - x := 'tmpVal'; - f.Get(TypeInfo(Double),x,tmpVal); - f.EndScopeRead(); - - AssertEquals(VAL_1,tmpVal); - Finally - s.Free(); - End; -end; - -procedure TTestFormatter.Test_Currency_8; -const VAL_1 = 12.10; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - tmpVal : Currency; -begin - s := Nil; - Try - tmpVal := VAL_1; - f := CreateFormatter(TypeInfo(TClass_Float)); - - f.BeginObject('Root',TypeInfo(TClass_Float)); - f.Put('tmpVal',TypeInfo(Currency),tmpVal); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - tmpVal := 0; - - f := CreateFormatter(TypeInfo(TClass_Float)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); - x := 'tmpVal'; - f.Get(TypeInfo(Currency),x,tmpVal); - f.EndScopeRead(); - - AssertEquals(VAL_1,tmpVal); - Finally - s.Free(); - End; -end; - -procedure TTestFormatter.Test_Extended_10; -const VAL_1 = 12.10; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - tmpVal : Extended; -begin - s := Nil; - Try - tmpVal := VAL_1; - f := CreateFormatter(TypeInfo(TClass_Float)); - - f.BeginObject('Root',TypeInfo(TClass_Float)); - f.Put('tmpVal',TypeInfo(Extended),tmpVal); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - tmpVal := 0; - - f := CreateFormatter(TypeInfo(TClass_Float)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Float),stObject); - x := 'tmpVal'; - f.Get(TypeInfo(Extended),x,tmpVal); - f.EndScopeRead(); - - AssertEquals(VAL_1,tmpVal); - Finally - s.Free(); - End; -end; - procedure TTestFormatter.Test_Float_WithClass; Var f : IFormatterBase; @@ -635,132 +1010,6 @@ begin End; end; -procedure TTestFormatter.Test_String; -const VAL_1 = 'AzErTy'; VAL_2 = 'QwErTy'; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - intVal_1 : string; intVal_3 : string; -begin - s := Nil; - Try - intVal_1 := VAL_1; - intVal_3 := VAL_2; - f := CreateFormatter(TypeInfo(TClass_Int)); - - f.BeginObject('Root',TypeInfo(TClass_Int)); - f.Put('intVal_1',TypeInfo(string),intVal_1); - f.Put('intVal_3',TypeInfo(string),intVal_3); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - intVal_1 := ''; - intVal_3 := 'yyyyyyyy'; - - f := CreateFormatter(TypeInfo(TClass_Int)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); - x := 'intVal_1'; - f.Get(TypeInfo(string),x,intVal_1); - x := 'intVal_3'; - f.Get(TypeInfo(string),x,intVal_3); - f.EndScopeRead(); - - AssertEquals(VAL_1,intVal_1); - AssertEquals(VAL_2,intVal_3); - Finally - s.Free(); - End; -end; - -procedure TTestFormatter.Test_Bool; -const VAL_1 = True; VAL_2 = False; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - intVal_1 : Boolean; intVal_3 : Boolean; -begin - s := Nil; - Try - intVal_1 := VAL_1; - intVal_3 := VAL_2; - f := CreateFormatter(TypeInfo(TClass_Int)); - - f.BeginObject('Root',TypeInfo(TClass_Int)); - f.Put('intVal_1',TypeInfo(Boolean),intVal_1); - f.Put('intVal_3',TypeInfo(Boolean),intVal_3); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - intVal_1 := False; - intVal_3 := True; - - f := CreateFormatter(TypeInfo(TClass_Int)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); - x := 'intVal_1'; - f.Get(TypeInfo(Boolean),x,intVal_1); - x := 'intVal_3'; - f.Get(TypeInfo(Boolean),x,intVal_3); - f.EndScopeRead(); - - AssertEquals(VAL_1,intVal_1); - AssertEquals(VAL_2,intVal_3); - Finally - s.Free(); - End; -end; - -procedure TTestFormatter.Test_Enum; -const VAL_1 = teTwo; VAL_2 = teFour; -Var - f : IFormatterBase; - s : TMemoryStream; - x : string; - intVal_1 : TTestEnum; intVal_3 : TTestEnum; -begin - s := Nil; - Try - intVal_1 := VAL_1; - intVal_3 := VAL_2; - f := CreateFormatter(TypeInfo(TClass_Int)); - - f.BeginObject('Root',TypeInfo(TClass_Enum)); - f.Put('intVal_1',TypeInfo(TTestEnum),intVal_1); - f.Put('intVal_3',TypeInfo(TTestEnum),intVal_3); - f.EndScope(); - - s := TMemoryStream.Create(); - f.SaveToStream(s); - intVal_1 := teOne; - intVal_3 := teOne; - - f := CreateFormatter(TypeInfo(TClass_Int)); - s.Position := 0; - f.LoadFromStream(s); - x := 'Root'; - f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); - x := 'intVal_1'; - f.Get(TypeInfo(TTestEnum),x,intVal_1); - x := 'intVal_3'; - f.Get(TypeInfo(TTestEnum),x,intVal_3); - f.EndScopeRead(); - - AssertEquals(Ord(VAL_1),Ord(intVal_1)); - AssertEquals(Ord(VAL_2),Ord(intVal_3)); - Finally - s.Free(); - End; -end; - procedure TTestFormatter.Test_Enum_Bool_String_WithClass; Var f : IFormatterBase; @@ -803,6 +1052,433 @@ begin End; end; +procedure TTestFormatter.Test_CplxInt64SimpleContent_WithClass; +const VAL_S = -12; VAL_U = 10; VAL_X = 121; + VAL_STR_S = 'Test Attribute S'; VAL_STR_U = 'Test Attribute U'; VAL_STR_X = 'test it'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexInt64SContentRemotable; + nu : TComplexInt64UContentRemotable; + x : string; +begin + s := nil; + ns := TComplexInt64SContentRemotable.Create(); + nu := TComplexInt64UContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxInt64S.Value := VAL_S; + a.Val_CplxInt64S.StrSimpleAtt_Exemple := VAL_STR_S; + a.Val_CplxInt64S.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt64S.BoolSimpleAtt_Exemple := True; + a.Elt_Exemple := VAL_STR_X; + ns.Value := VAL_S; + + a.Val_CplxInt64U.Value := VAL_U; + a.Val_CplxInt64U.StrSimpleAtt_Exemple := VAL_STR_U; + a.Val_CplxInt64U.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt64U.BoolSimpleAtt_Exemple := False; + nu.Value := VAL_U; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexInt64SContentRemotable),ns); + f.Put('nu',TypeInfo(TComplexInt64UContentRemotable),nu); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexInt64SContentRemotable),x,ns); + x := 'nu'; + f.Get(TypeInfo(TComplexInt64UContentRemotable),x,nu); + f.EndScopeRead(); + + AssertEquals(VAL_S,a.Val_CplxInt64S.Value); + AssertEquals(VAL_X,a.Val_CplxInt64S.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_S,a.Val_CplxInt64S.StrSimpleAtt_Exemple); + AssertEquals(True,a.Val_CplxInt64S.BoolSimpleAtt_Exemple); + AssertEquals(VAL_STR_X,a.Elt_Exemple); + + AssertEquals(VAL_U,a.Val_CplxInt64U.Value); + AssertEquals(VAL_X,a.Val_CplxInt64U.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_U,a.Val_CplxInt64U.StrSimpleAtt_Exemple); + AssertEquals(False,a.Val_CplxInt64U.BoolSimpleAtt_Exemple); + finally + FreeAndNil(nu); + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + +procedure TTestFormatter.Test_CplxInt32SimpleContent_WithClass; +const VAL_S = -12; VAL_U = 10; VAL_X = 1210; + VAL_STR_S = 'Test Attribute S'; VAL_STR_U = 'Test Attribute U'; VAL_STR_X = 'test it'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexInt32SContentRemotable; + nu : TComplexInt32UContentRemotable; + x : string; +begin + s := nil; + ns := TComplexInt32SContentRemotable.Create(); + nu := TComplexInt32UContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxInt32S.Value := VAL_S; + a.Val_CplxInt32S.StrSimpleAtt_Exemple := VAL_STR_S; + a.Val_CplxInt32S.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt32S.BoolSimpleAtt_Exemple := True; + a.Elt_Exemple := VAL_STR_X; + ns.Value := VAL_S; + + a.Val_CplxInt32U.Value := VAL_U; + a.Val_CplxInt32U.StrSimpleAtt_Exemple := VAL_STR_U; + a.Val_CplxInt32U.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt32U.BoolSimpleAtt_Exemple := False; + nu.Value := VAL_U; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexInt32SContentRemotable),ns); + f.Put('nu',TypeInfo(TComplexInt32UContentRemotable),nu); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexInt32SContentRemotable),x,ns); + x := 'nu'; + f.Get(TypeInfo(TComplexInt32UContentRemotable),x,nu); + f.EndScopeRead(); + + AssertEquals(VAL_S,a.Val_CplxInt32S.Value); + AssertEquals(VAL_X,a.Val_CplxInt32S.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_S,a.Val_CplxInt32S.StrSimpleAtt_Exemple); + AssertEquals(True,a.Val_CplxInt32S.BoolSimpleAtt_Exemple); + AssertEquals(VAL_STR_X,a.Elt_Exemple); + + AssertEquals(VAL_U,a.Val_CplxInt32U.Value); + AssertEquals(VAL_X,a.Val_CplxInt32U.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_U,a.Val_CplxInt32U.StrSimpleAtt_Exemple); + AssertEquals(False,a.Val_CplxInt32U.BoolSimpleAtt_Exemple); + finally + FreeAndNil(nu); + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + +procedure TTestFormatter.Test_CplxInt16SimpleContent_WithClass; +const VAL_S = -12; VAL_U = 10; VAL_X = 1210; + VAL_STR_S = 'Test Attribute S'; VAL_STR_U = 'Test Attribute U'; VAL_STR_X = 'test it'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexInt16SContentRemotable; + nu : TComplexInt16UContentRemotable; + x : string; +begin + s := nil; + ns := TComplexInt16SContentRemotable.Create(); + nu := TComplexInt16UContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxInt16S.Value := VAL_S; + a.Val_CplxInt16S.StrSimpleAtt_Exemple := VAL_STR_S; + a.Val_CplxInt16S.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt16S.BoolSimpleAtt_Exemple := True; + a.Elt_Exemple := VAL_STR_X; + ns.Value := VAL_S; + + a.Val_CplxInt16U.Value := VAL_U; + a.Val_CplxInt16U.StrSimpleAtt_Exemple := VAL_STR_U; + a.Val_CplxInt16U.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt16U.BoolSimpleAtt_Exemple := False; + nu.Value := VAL_U; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexInt16SContentRemotable),ns); + f.Put('nu',TypeInfo(TComplexInt16UContentRemotable),nu); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexInt16SContentRemotable),x,ns); + x := 'nu'; + f.Get(TypeInfo(TComplexInt16UContentRemotable),x,nu); + f.EndScopeRead(); + + AssertEquals(VAL_S,a.Val_CplxInt16S.Value); + AssertEquals(VAL_X,a.Val_CplxInt16S.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_S,a.Val_CplxInt16S.StrSimpleAtt_Exemple); + AssertEquals(True,a.Val_CplxInt16S.BoolSimpleAtt_Exemple); + AssertEquals(VAL_STR_X,a.Elt_Exemple); + + AssertEquals(VAL_U,a.Val_CplxInt16U.Value); + AssertEquals(VAL_X,a.Val_CplxInt16U.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_U,a.Val_CplxInt16U.StrSimpleAtt_Exemple); + AssertEquals(False,a.Val_CplxInt16U.BoolSimpleAtt_Exemple); + finally + FreeAndNil(nu); + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + +procedure TTestFormatter.Test_CplxInt8SimpleContent_WithClass; +const VAL_S = -12; VAL_U = 10; VAL_X = 121; + VAL_STR_S = 'Test Attribute S'; VAL_STR_U = 'Test Attribute U'; VAL_STR_X = 'test it'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexInt8SContentRemotable; + nu : TComplexInt8UContentRemotable; + x : string; +begin + s := nil; + ns := TComplexInt8SContentRemotable.Create(); + nu := TComplexInt8UContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxInt8S.Value := VAL_S; + a.Val_CplxInt8S.StrSimpleAtt_Exemple := VAL_STR_S; + a.Val_CplxInt8S.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt8S.BoolSimpleAtt_Exemple := True; + a.Elt_Exemple := VAL_STR_X; + ns.Value := VAL_S; + + a.Val_CplxInt8U.Value := VAL_U; + a.Val_CplxInt8U.StrSimpleAtt_Exemple := VAL_STR_U; + a.Val_CplxInt8U.IntSimpleAtt_Exemple := VAL_X; + a.Val_CplxInt8U.BoolSimpleAtt_Exemple := False; + nu.Value := VAL_U; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexInt8SContentRemotable),ns); + f.Put('nu',TypeInfo(TComplexInt8UContentRemotable),nu); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexInt8SContentRemotable),x,ns); + x := 'nu'; + f.Get(TypeInfo(TComplexInt8UContentRemotable),x,nu); + f.EndScopeRead(); + + AssertEquals(VAL_S,a.Val_CplxInt8S.Value); + AssertEquals(VAL_X,a.Val_CplxInt8S.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_S,a.Val_CplxInt8S.StrSimpleAtt_Exemple); + AssertEquals(True,a.Val_CplxInt8S.BoolSimpleAtt_Exemple); + AssertEquals(VAL_STR_X,a.Elt_Exemple); + + AssertEquals(VAL_U,a.Val_CplxInt8U.Value); + AssertEquals(VAL_X,a.Val_CplxInt8U.IntSimpleAtt_Exemple); + AssertEquals(VAL_STR_U,a.Val_CplxInt8U.StrSimpleAtt_Exemple); + AssertEquals(False,a.Val_CplxInt8U.BoolSimpleAtt_Exemple); + finally + FreeAndNil(nu); + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + +procedure TTestFormatter.Test_CplxFloatExtendedSimpleContent_WithClass; +const VAL_S = -12.10; VAL_U = 10.76; VAL_X = 1210.76; + VAL_STR_S = 'Test Attribute S'; VAL_STR_U = 'Test Attribute U'; VAL_STR_X = 'test it'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexFloatExtendedContentRemotable; + nu : TComplexFloatDoubleContentRemotable; + x : string; +begin + s := nil; + ns := TComplexFloatExtendedContentRemotable.Create(); + nu := TComplexFloatDoubleContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxExtended := T_ComplexFloatExtendedContent.Create(); + a.Val_CplxExtended.Value := VAL_S; + a.Val_CplxDouble := T_ComplexFloatDoubleContent.Create(); + a.Val_CplxDouble.Value := VAL_U; + + a.Val_CplxInt32S.Free(); + a.Val_CplxInt32S := nil; + a.Val_CplxInt32U.Free(); + a.Val_CplxInt32U := nil; + + ns.Value := VAL_S; + nu.Value := VAL_U; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexFloatExtendedContentRemotable),ns); + f.Put('nu',TypeInfo(TComplexFloatDoubleContentRemotable),nu); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + a.Val_CplxInt32S.Free(); + a.Val_CplxInt32S := nil; + a.Val_CplxInt32U.Free(); + a.Val_CplxInt32U := nil; + a.Val_CplxExtended := T_ComplexFloatExtendedContent.Create(); + a.Val_CplxDouble := T_ComplexFloatDoubleContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexFloatExtendedContentRemotable),x,ns); + x := 'nu'; + f.Get(TypeInfo(TComplexFloatDoubleContentRemotable),x,nu); + f.EndScopeRead(); + + AssertEquals('VAL_S <> a.Val_CplxExtended.Value',VAL_S,a.Val_CplxExtended.Value); + AssertEquals('VAL_S <> a.Val_CplxDouble.Value',VAL_U,a.Val_CplxDouble.Value); + AssertEquals('VAL_S <> ns.Value',VAL_S,ns.Value); + AssertEquals('VAL_U <> nu.Value',VAL_U,nu.Value); + AssertNull('a.Val_CplxInt32S <> nil',a.Val_CplxInt32S); + AssertNull('a.Val_CplxInt32U <> nil',a.Val_CplxInt32U); + finally + FreeAndNil(nu); + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + +procedure TTestFormatter.Test_CplxStringSimpleContent_WithClass; +const VAL_S = 'web services toolkit'; + VAL_STR_S = 'Test Attribute S'; +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_CplxSimpleContent; + ns : TComplexStringContentRemotable; + x : string; +begin + s := nil; + ns := TComplexStringContentRemotable.Create(); + a := TClass_CplxSimpleContent.Create(); + try + a.Val_CplxString := T_ComplexStringContent.Create(); + a.Val_CplxString.Value := VAL_S; + a.Val_CplxInt32S.Free(); + a.Val_CplxInt32S := nil; + a.Val_CplxInt32U.Free(); + a.Val_CplxInt32U := nil; + + ns.Value := VAL_STR_S; + + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('o1',TypeInfo(TClass_CplxSimpleContent),a); + f.Put('ns',TypeInfo(TComplexStringContentRemotable),ns); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.txt'); + FreeAndNil(a); + + a := TClass_CplxSimpleContent.Create(); + a.Val_CplxInt32S.Free(); + a.Val_CplxInt32S := nil; + a.Val_CplxInt32U.Free(); + a.Val_CplxInt32U := nil; + a.Val_CplxString := T_ComplexStringContent.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_CplxSimpleContent),x,a); + x := 'ns'; + f.Get(TypeInfo(TComplexStringContentRemotable),x,ns); + f.EndScopeRead(); + + AssertEquals('VAL_S <> a.Val_CplxString.Value',VAL_S,a.Val_CplxString.Value); + AssertEquals('VAL_STR_S <> ns.Value',VAL_STR_S,ns.Value); + finally + FreeAndNil(ns); + a.Free(); + s.Free(); + end; +end; + procedure TTestFormatter.Test_Object(); Var f : IFormatterBase; @@ -859,8 +1535,40 @@ begin end; procedure TTestFormatter.Test_Object_Nil(); +var + f : IFormatterBase; + s : TMemoryStream; + a : TClass_B; + x : string; begin - Fail('Write me!'); + s := nil; + a := nil; + try + f := CreateFormatter(TypeInfo(TClass_B)); + + f.BeginObject('Root',TypeInfo(TClass_B)); + f.Put('o1',TypeInfo(TClass_B),a); + f.EndScope(); + + s := TMemoryStream.Create(); + f.SaveToStream(s); + FreeAndNil(a); + + a := nil; + f := CreateFormatter(TypeInfo(TClass_B)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_B),stObject); + x := 'o1'; + f.Get(TypeInfo(TClass_B),x,a); + f.EndScopeRead(); + + AssertNull(a); + finally + a.Free(); + s.Free(); + end; end; procedure TTestFormatter.Test_StringArray(); @@ -1599,6 +2307,54 @@ begin end; end; +procedure TTestFormatter.Test_ComplexInt32S(); +const VAL_1 = 121076; VAL_2 : LongInt = -101276; +var + f : IFormatterBase; + s : TMemoryStream; + x : string; + a, b : TComplexInt32SContentRemotable; +begin + s := nil; + a := nil; + b := nil; + try + a := TComplexInt32SContentRemotable.Create(); + b := TComplexInt32SContentRemotable.Create(); + a.Value := VAL_1; + b.Value := VAL_2; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('a',TypeInfo(TComplexInt32SContentRemotable),a); + f.Put('b',TypeInfo(TComplexInt32SContentRemotable),b); + f.EndScope(); + FreeAndNil(a);FreeAndNil(b); + s := TMemoryStream.Create(); + f.SaveToStream(s); + + a := TComplexInt32SContentRemotable.Create(); + b := TComplexInt32SContentRemotable.Create(); + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginScopeRead(x,TypeInfo(TClass_Int),stObject); + x := 'a'; + f.Get(TypeInfo(TComplexInt32SContentRemotable),x,a); + x := 'b'; + f.Get(TypeInfo(TComplexInt32SContentRemotable),x,b); + f.EndScopeRead(); + + AssertEquals(VAL_1,a.Value); + AssertEquals(VAL_2,b.Value); + finally + s.Free(); + FreeAndNil(a); + FreeAndNil(b); + end; +end; + { TTestBinaryFormatter } @@ -2110,7 +2866,8 @@ end; function TTestSOAPFormatterAttributes.CreateFormatter(ARootType: PTypeInfo): IFormatterBase; begin - Result := inherited CreateFormatter(ARootType); + Result := TSOAPBaseFormatter.Create() as IFormatterBase; + Result.BeginObject('Env',ARootType); Result.SetSerializationStyle(ssAttibuteSerialization); end; @@ -2118,19 +2875,119 @@ end; function TTestBinaryFormatterAttributes.CreateFormatter(ARootType: PTypeInfo): IFormatterBase; begin - Result := inherited CreateFormatter(ARootType); + Result := TSOAPBaseFormatter.Create() as IFormatterBase; + Result.BeginObject('Env',ARootType); Result.SetSerializationStyle(ssAttibuteSerialization); end; +{ TClass_CplxSimpleContent } + +constructor TClass_CplxSimpleContent.Create(); +begin + FVal_CplxInt64S := T_ComplexInt64SContent.Create(); + FVal_CplxInt64U := T_ComplexInt64UContent.Create(); + FVal_CplxInt32S := T_ComplexInt32SContent.Create(); + FVal_CplxInt32U := T_ComplexInt32UContent.Create(); + FVal_CplxInt16S := T_ComplexInt16SContent.Create(); + FVal_CplxInt16U := T_ComplexInt16UContent.Create(); + FVal_CplxInt8S := T_ComplexInt8SContent.Create(); + FVal_CplxInt8U := T_ComplexInt8UContent.Create(); +end; + +destructor TClass_CplxSimpleContent.Destroy(); +begin + FreeAndNil(FVal_CplxInt64S); + FreeAndNil(FVal_CplxInt64U); + FreeAndNil(FVal_CplxInt32U); + FreeAndNil(FVal_CplxInt32S); + FreeAndNil(FVal_CplxInt16U); + FreeAndNil(FVal_CplxInt16S); + FreeAndNil(FVal_CplxInt8U); + FreeAndNil(FVal_CplxInt8S); + inherited Destroy(); +end; + +{ TTest_TDateRemotable } + +procedure TTest_TDateRemotable.FormatDate(); +const sDATE = '1976-10-12T23:34:56'; +var + d : TDateTime; +begin + //'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)? + d := EncodeDate(1976,10,12) + EncodeTime(23,34,56,0); + AssertTrue(AnsiPos(TDateRemotable.FormatDate(d),sDATE) = 1); +end; + +procedure TTest_TDateRemotable.ParseDate(); +const sDATE = '1976-10-12T23:34:56'; +var + s : string; + objd : TDateRemotable; + d : TDateTime; + y,m,dy : Word; + hh,mn,ss, ssss : Word; +begin + //'-'? yyyy '-' mm '-' dd 'T' hh ':' mm ':' ss ('.' s+)? (zzzzzz)? + s := '1976-10-12T23:34:56'; + d := TDateRemotable.ParseDate(s); + DecodeDate(d,y,m,dy); + AssertEquals('Year',y,1976); + AssertEquals('Month',m,10); + AssertEquals('Day',dy,12); + + DecodeTime(d,hh,mn,ss,ssss); + AssertEquals('Hour',hh,23); + AssertEquals('Minute',mn,34); + AssertEquals('Second',ss,56); + + objd := TDateRemotable.Create(); + try + objd.AsDate := d; + AssertEquals('Year',objd.Year,1976); + AssertEquals('Month',objd.Month,10); + AssertEquals('Day',objd.Day,12); + AssertEquals('Hour',objd.Hour,23); + AssertEquals('Minute',objd.Minute,34); + AssertEquals('Second',objd.Second,56); + finally + FreeAndNil(objd); + end; +end; + +{ TTest_TDurationRemotable } + +procedure TTest_TDurationRemotable.FormatDate(); +begin + Fail('Write me!'); +end; + +procedure TTest_TDurationRemotable.ParseDate(); +begin + Fail('Write me!'); +end; + initialization RegisterStdTypes(); - GetTypeRegistry().Register(sXSD_NS,TypeInfo(TTestEnum),'TTestEnum'); - GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_Int),'TClass_Int'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(TTestEnum),'TTestEnum').RegisterExternalPropertyName('teOne', '1'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_Int),'TClass_Int').RegisterExternalPropertyName('Val_8U','U8'); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_Enum),'TClass_Enum'); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_A),'TClass_A'); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_B),'TClass_B'); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_Float),'TClass_Float'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexInt32SContent),'T_ComplexInt32SContent'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexInt32UContent),'T_ComplexInt32UContent'); + + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexInt16SContent),'T_ComplexInt16SContent'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexInt16UContent),'T_ComplexInt16UContent'); + + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexFloatExtendedContent),'T_ComplexFloatExtendedContent'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(T_ComplexFloatDoubleContent),'T_ComplexFloatDoubleContent'); + + TClass_CplxSimpleContent.RegisterAttributeProperty('Elt_Exemple'); + GetTypeRegistry().Register(sXSD_NS,TypeInfo(TClass_CplxSimpleContent),'TClass_CplxSimpleContent').RegisterExternalPropertyName('Elt_Exemple', 'published'); + RegisterTest(TTestArray); RegisterTest(TTestSOAPFormatter); @@ -2138,5 +2995,6 @@ initialization RegisterTest(TTest_TBaseComplexRemotable); RegisterTest(TTestSOAPFormatterAttributes); RegisterTest(TTestBinaryFormatterAttributes); + RegisterTest(TTest_TDateRemotable); + RegisterTest(TTest_TDurationRemotable); end. - diff --git a/wst/trunk/tests/test_suite/wst_test_suite.lpi b/wst/trunk/tests/test_suite/wst_test_suite.lpi index ee5306123..3100941d8 100644 --- a/wst/trunk/tests/test_suite/wst_test_suite.lpi +++ b/wst/trunk/tests/test_suite/wst_test_suite.lpi @@ -7,7 +7,7 @@ - + @@ -18,7 +18,7 @@ - + @@ -27,23 +27,23 @@ - + - - - + + + - - - - + + + + @@ -52,49 +52,50 @@ - - - + - - - - - + + + - - - - - + + + + + + - - + + - + + + + - - - - - + + + + + + @@ -102,17 +103,15 @@ - - - + - - - + + + @@ -120,281 +119,351 @@ - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + - - - + + + - - - + + + - - - - - - + + + + - - - + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + - - - - - + + + + + + + - - - - - - - - - - - - - - - - - - - - - + + - - - - - - - - - - - - - - - - + + + - - - + + + - - - - - - + + + + - - - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - - + + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -423,7 +492,7 @@ - + @@ -477,29 +546,9 @@ - - - - - - - - - - - - - - - - - - - - - + diff --git a/wst/trunk/tests/test_suite/wst_test_suite.lpr b/wst/trunk/tests/test_suite/wst_test_suite.lpr index 917b78093..784583a89 100644 --- a/wst/trunk/tests/test_suite/wst_test_suite.lpr +++ b/wst/trunk/tests/test_suite/wst_test_suite.lpr @@ -8,7 +8,8 @@ uses server_service_soap, soap_formatter, base_binary_formatter, base_service_intf, base_soap_formatter, binary_formatter, binary_streamer, server_binary_formatter, metadata_repository, - metadata_generator, parserdefs, server_service_intf, metadata_wsdl; + metadata_generator, parserdefs, server_service_intf, metadata_wsdl, + test_parserdef; Const ShortOpts = 'alh'; diff --git a/wst/trunk/ws_helper/command_line_parser.pas b/wst/trunk/ws_helper/command_line_parser.pas index 23f435a13..1f4a0bfbb 100644 --- a/wst/trunk/ws_helper/command_line_parser.pas +++ b/wst/trunk/ws_helper/command_line_parser.pas @@ -28,7 +28,10 @@ uses Type - TComandLineOption = ( cloProxy, cloImp, cloBinder, cloOutPutDir ); + TComandLineOption = ( + cloInterface, cloProxy, cloImp, cloBinder, + cloOutPutDirRelative, cloOutPutDirAbsolute + ); TComandLineOptions = set of TComandLineOption; function ParseCmdLineOptions(out AAppOptions : TComandLineOptions):Integer; @@ -53,15 +56,21 @@ begin AAppOptions := []; c := #0; Repeat - c := GetOpt('pibo:'); + c := GetOpt('upibo:a:'); case c of + 'u' : Include(AAppOptions,cloInterface); 'p' : Include(AAppOptions,cloProxy); 'i' : Include(AAppOptions,cloImp); 'b' : Include(AAppOptions,cloBinder); 'o' : Begin - Include(AAppOptions,cloOutPutDir); - OptionsArgsMAP[cloOutPutDir] := OptArg; + Include(AAppOptions,cloOutPutDirRelative); + OptionsArgsMAP[cloOutPutDirRelative] := OptArg; + End; + 'a' : + Begin + Include(AAppOptions,cloOutPutDirAbsolute); + OptionsArgsMAP[cloOutPutDirAbsolute] := OptArg; End; end; Until ( c = EndOfOptions ); diff --git a/wst/trunk/ws_helper/generator.pas b/wst/trunk/ws_helper/generator.pas index 7091b364c..40d8c1ccd 100644 --- a/wst/trunk/ws_helper/generator.pas +++ b/wst/trunk/ws_helper/generator.pas @@ -139,9 +139,39 @@ type procedure Execute();override; End; + { TInftGenerator } + TInftGenerator = class(TBaseGenerator) + private + FDecStream : ISourceStream; + FImpStream : ISourceStream; + FImpTempStream : ISourceStream; + private + function GenerateIntfName(AIntf : TInterfaceDefinition):string; + + procedure GenerateUnitHeader(); + procedure GenerateUnitImplementationHeader(); + procedure GenerateUnitImplementationFooter(); + + procedure GenerateIntf(AIntf : TInterfaceDefinition); + procedure GenerateTypeAlias(ASymbol : TTypeAliasDefinition); + procedure GenerateClass(ASymbol : TClassTypeDefinition); + procedure GenerateEnum(ASymbol : TEnumTypeDefinition); + procedure GenerateArray(ASymbol : TArrayDefinition); + + function GetDestUnitName():string; + public + constructor Create( + ASymTable : TSymbolTable; + ASrcMngr : ISourceManager + ); + procedure Execute();override; + end; + + + implementation -uses parserutils; +uses parserutils, Contnrs; Const sPROXY_BASE_CLASS = 'TBaseProxy'; sBINDER_BASE_CLASS = 'TBaseServiceBinder'; @@ -149,6 +179,7 @@ Const sPROXY_BASE_CLASS = 'TBaseProxy'; sSERIALIZER_CLASS = 'IFormatterClient'; RETURN_PARAM_NAME = 'return'; RETURN_VAL_NAME = 'returnVal'; + sNAME_SPACE = 'sNAME_SPACE'; sPRM_NAME = 'strPrmName'; sLOC_SERIALIZER = 'locSerializer'; @@ -377,7 +408,7 @@ Var Indent();WriteLn('%s := GetSerializer();',[sLOC_SERIALIZER]); Indent();WriteLn('Try');IncIndent(); - Indent();WriteLn('%s.BeginCall(''%s'', GetTarget(),(Self as ICallContext));',[sLOC_SERIALIZER,AMthd.Name]); + Indent();WriteLn('%s.BeginCall(''%s'', GetTarget(),(Self as ICallContext));',[sLOC_SERIALIZER,AMthd.ExternalName]); IncIndent(); prmCnt := AMthd.ParameterCount; If ( AMthd.MethodType = mtFunction ) Then @@ -385,7 +416,7 @@ Var For k := 0 To Pred(prmCnt) Do Begin prm := AMthd.Parameter[k]; If ( prm.Modifier <> pmOut ) Then Begin - Indent();WriteLn('%s.Put(''%s'', TypeInfo(%s), %s);',[sLOC_SERIALIZER,prm.Name,prm.DataType.Name,prm.Name]); + Indent();WriteLn('%s.Put(%s, TypeInfo(%s), %s);',[sLOC_SERIALIZER,QuotedStr(prm.ExternalName),prm.DataType.Name,prm.Name]); End; End; DecIndent(); @@ -402,8 +433,10 @@ Var prm := AMthd.Parameter[k]; //Indent();WriteLn('%s := TypeInfo(%s);',[sRES_TYPE_INFO,prm.DataType.Name]); if prm.DataType.NeedFinalization() then begin - if prm.DataType.InheritsFrom(TClassTypeDefinition) then begin - Indent();WriteLn('Pointer(Result) := Nil;'); + if prm.DataType.InheritsFrom(TClassTypeDefinition) or + prm.DataType.InheritsFrom(TArrayDefinition) + then begin + Indent();WriteLn('TObject(Result) := Nil;'); end else begin Indent();WriteLn('If ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) Then',[prm.DataType.Name]); IncIndent(); @@ -411,20 +444,24 @@ Var DecIndent(); end; end; - Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(RETURN_PARAM_NAME)]); - Indent();WriteLn('%s.Get(TypeInfo(%s), %s, %s);',[sLOC_SERIALIZER,prm.DataType.Name,sPRM_NAME,prm.Name]); + Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(prm.ExternalName)]);//Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(RETURN_PARAM_NAME)]); + Indent();WriteLn('%s.Get(TypeInfo(%s), %s, %s);',[sLOC_SERIALIZER,prm.DataType.Name,sPRM_NAME,'Result']); End; //-------------------------------- for k := 0 to Pred(prmCnt) do begin prm := AMthd.Parameter[k]; if ( prm.Modifier = pmOut ) then begin - if prm.DataType.InheritsFrom(TClassTypeDefinition) then begin - Indent();WriteLn('Pointer(%s) := Nil;',[prm.Name]); - end else begin - Indent();WriteLn('If ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) Then',[prm.DataType.Name]); - IncIndent(); - Indent();WriteLn('Pointer(%s) := Nil;',[prm.Name]); - DecIndent(); + if prm.DataType.NeedFinalization() then begin + if prm.DataType.InheritsFrom(TClassTypeDefinition) or + prm.DataType.InheritsFrom(TArrayDefinition) + then begin + Indent();WriteLn('TObject(%s) := Nil;',[prm.Name]); + end else begin + Indent();WriteLn('If ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) Then',[prm.DataType.Name]); + IncIndent(); + Indent();WriteLn('Pointer(%s) := Nil;',[prm.Name]); + DecIndent(); + end; end; end; end; @@ -433,7 +470,7 @@ Var For k := 0 To Pred(prmCnt) Do Begin prm := AMthd.Parameter[k]; If ( prm.Modifier In [pmVar, pmOut] ) Then Begin - Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(prm.Name)]); + Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(prm.ExternalName)]); Indent();WriteLn('%s.Get(TypeInfo(%s), %s, %s);',[sLOC_SERIALIZER,prm.DataType.Name,sPRM_NAME,prm.Name]); End; End; @@ -766,7 +803,7 @@ Var NewLine(); For k := 0 To Pred(prmCnt) Do Begin prm := AMthd.Parameter[k]; - Write('%s := %s;',[sPRM_NAME,QuotedStr(prm.Name)]); + Write('%s := %s;',[sPRM_NAME,QuotedStr(prm.ExternalName)]); WriteLn('AFormatter.Get(TypeInfo(%s),%s,%s);',[prm.DataType.Name,sPRM_NAME,prm.Name]); If prm.DataType.NeedFinalization() Then Begin if prm.DataType.InheritsFrom(TClassTypeDefinition) then begin @@ -824,20 +861,20 @@ Var WriteLn('AFormatter.Clear();'); WriteLn('AFormatter.BeginCallResponse(procName,trgName);'); - //BeginAutoIndent(); IncIndent(); - If ( AMthd.MethodType = mtFunction ) Then - WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(RETURN_PARAM_NAME),AMthd.Parameter[prmCnt].DataType.Name,RETURN_VAL_NAME]); + if ( AMthd.MethodType = mtFunction ) then begin + //WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(RETURN_PARAM_NAME),AMthd.Parameter[prmCnt].DataType.Name,RETURN_VAL_NAME]); + WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(prm.ExternalName),AMthd.Parameter[prmCnt].DataType.Name,RETURN_VAL_NAME]); + end; For k := 0 To Pred(prmCnt) Do Begin prm := AMthd.Parameter[k]; If ( prm.Modifier In [pmOut,pmVar] ) Then - WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(prm.Name),prm.DataType.Name,prm.Name]); + WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(prm.ExternalName),prm.DataType.Name,prm.Name]); End; DecIndent(); WriteLn('AFormatter.EndCallResponse();'); NewLine(); WriteLn('callCtx := Nil;'); - //EndAutoIndent(); DecIndent();EndAutoIndent(); WriteLn('End;'); @@ -1206,4 +1243,637 @@ begin FImpStream := Nil; end; +{ TInftGenerator } + +function TInftGenerator.GenerateIntfName(AIntf: TInterfaceDefinition): string; +begin + Result := ExtractserviceName(AIntf); +end; + +procedure TInftGenerator.GenerateUnitHeader(); +begin + SetCurrentStream(FDecStream); + WriteLn('{'); + WriteLn('This unit has been produced by ws_helper.'); + WriteLn(' Input unit name : "%s".',[SymbolTable.Name]); + WriteLn(' This unit name : "%s".',[GetDestUnitName()]); + WriteLn(' Date : "%s".',[DateTimeToStr(Now())]); + WriteLn('}'); + + WriteLn('unit %s;',[GetDestUnitName()]); + WriteLn('{$mode objfpc}{$H+}'); + WriteLn('interface'); + WriteLn(''); + WriteLn('uses SysUtils, Classes, TypInfo, base_service_intf, service_intf;'); + WriteLn(''); + WriteLn('const'); + + IncIndent(); + Indent();WriteLn('sNAME_SPACE = %s;',[QuotedStr(FSymbolTable.ExternalName)]); + DecIndent(); + + WriteLn(''); + WriteLn('type'); + WriteLn(''); +end; + +procedure TInftGenerator.GenerateUnitImplementationHeader(); +begin + SetCurrentStream(FImpStream); + WriteLn(''); + WriteLn('Implementation'); + FImpTempStream.WriteLn('initialization'); +end; + +procedure TInftGenerator.GenerateUnitImplementationFooter(); +begin + SetCurrentStream(FImpStream); + NewLine(); + NewLine(); + FImpTempStream.NewLine(); + FImpTempStream.WriteLn('End.'); +end; + +procedure TInftGenerator.GenerateIntf(AIntf: TInterfaceDefinition); + + procedure WriteDec(); + begin + Indent(); + WriteLn('%s = interface',[GenerateIntfName(AIntf)]); + end; + + procedure WriteMethod(AMthd : TMethodDefinition); + Var + prmCnt,k : Integer; + prm : TParameterDefinition; + Begin + Indent(); + prmCnt := AMthd.ParameterCount; + If ( AMthd.MethodType = mtProcedure ) Then + Write('procedure ') + Else Begin + Write('function '); + Dec(prmCnt); + End; + Write('%s(',[AMthd.Name]); + + If ( prmCnt > 0 ) Then Begin + IncIndent(); + For k := 0 To Pred(prmCnt) Do Begin + prm := AMthd.Parameter[k]; + If (k > 0 ) Then + Write('; '); + NewLine(); + Indent(); + Write('%s %s : %s',[ParameterModifierMAP[prm.Modifier],prm.Name,prm.DataType.Name]); + End; + DecIndent(); + NewLine(); + Indent(); + End; + + Write(')'); + If ( AMthd.MethodType = mtFunction ) Then Begin + Write(':%s',[AMthd.Parameter[prmCnt].DataType.Name]); + End; + WriteLn(';'); + End; + + procedure WriteMethods(); + Var + k : Integer; + begin + If ( AIntf.MethodCount = 0 ) Then + Exit; + IncIndent(); + For k := 0 To Pred(AIntf.MethodCount) Do + WriteMethod(AIntf.Method[k]); + DecIndent(); + end; + +begin + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + WriteDec(); + WriteMethods(); + Indent(); WriteLn('end;'); + DecIndent(); +end; + +procedure TInftGenerator.GenerateTypeAlias(ASymbol: TTypeAliasDefinition); +begin + try + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + Indent(); + WriteLn('%s = type %s;',[ASymbol.Name,ASymbol.BaseType.Name]); + DecIndent(); + except + on e : Exception do + System.WriteLn('TInftGenerator.GenerateTypeAlias()=', ASymbol.Name, ' ;; ', e.Message); + end; +end; + +procedure TInftGenerator.GenerateClass(ASymbol: TClassTypeDefinition); +var + locClassPropNbr, locStoredPropsNbr : Integer; + loc_BaseComplexSimpleContentRemotable : TClassTypeDefinition; + + procedure Prepare(); + var + k : Integer; + p : TPropertyDefinition; + begin + locClassPropNbr := 0; + locStoredPropsNbr := 0; + for k := 0 to Pred(ASymbol.PropertyCount) do begin + p := ASymbol.Properties[k]; + if ( p.StorageOption = soOptional ) then + Inc(locStoredPropsNbr); + if p.DataType.InheritsFrom(TClassTypeDefinition) then + Inc(locClassPropNbr); + end; + end; + + procedure WriteDec(); + var + s : string; + begin + if Assigned(ASymbol.Parent) then begin + {if ASymbol.Parent.InheritsFrom(TNativeSimpleTypeDefinition) and + Assigned(TNativeSimpleTypeDefinition(ASymbol.Parent).BoxedType) + then begin + s := Format('%s',[TNativeSimpleTypeDefinition(ASymbol.Parent).BoxedType.Name]); + end else begin + s := Format('%s',[ASymbol.Parent.Name]); + end;} + s := Format('%s',[ASymbol.Parent.Name]); + end else begin + s := 'XX';//'TBaseComplexRemotable'; + end; + Indent(); + WriteLn('%s = class(%s)',[ASymbol.Name,s]); + end; + + procedure WritePropertyField(AProp : TPropertyDefinition); + begin + Indent(); + WriteLn('F%s : %s;',[AProp.Name,AProp.DataType.Name]); + End; + + procedure WriteProperty(AProp : TPropertyDefinition); + var + propName, locStore : string; + begin + propName := AProp.Name; + case AProp.StorageOption of + soAlways : locStore := ''; + soNever : locStore := ' stored False'; + soOptional : locStore := Format(' stored Has%s',[AProp.Name]); + end; + Indent(); + WriteLn('property %s : %s read F%s write F%s%s;',[propName,AProp.DataType.Name,propName,propName,locStore]); + if not AnsiSameText(AProp.Name,AProp.ExternalName) then begin + FImpTempStream.Indent(); + FImpTempStream.WriteLn('GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);',[ASymbol.Name,QuotedStr(AProp.Name),QuotedStr(AProp.ExternalName)]); + end; + if AProp.IsAttribute and ( not ASymbol.IsDescendantOf(loc_BaseComplexSimpleContentRemotable) ) then begin + FImpTempStream.Indent(); + FImpTempStream.WriteLn('%s.RegisterAttributeProperty(%s);',[ASymbol.Name,QuotedStr(AProp.Name)]); + end; + end; + + procedure WriteProperties(); + Var + k : Integer; + p : TPropertyDefinition; + begin + If ( ASymbol.PropertyCount > 0 ) Then begin + Indent(); + WriteLn('private'); + IncIndent(); + for k := 0 to Pred(ASymbol.PropertyCount) do begin + p := ASymbol.Properties[k]; + WritePropertyField(p); + end; + DecIndent(); + // + if ( locStoredPropsNbr > 0 ) then begin + Indent(); + WriteLn('private'); + IncIndent(); + for k := 0 to Pred(ASymbol.PropertyCount) do begin + p := ASymbol.Properties[k]; + if ( p.StorageOption = soOptional ) then begin + Indent(); + WriteLn('function Has%s() : Boolean;',[p.Name]); + end; + end; + DecIndent(); + end; + // + if ( locClassPropNbr > 0 ) then begin + Indent(); + WriteLn('public'); + IncIndent(); + Indent(); + WriteLn('destructor Destroy();override;'); + DecIndent(); + end; + // + Indent(); + WriteLn('published'); + IncIndent(); + For k := 0 To Pred(ASymbol.PropertyCount) Do + WriteProperty(ASymbol.Properties[k]); + DecIndent(); + end; + end; + + procedure WriteImp(); + var + k : Integer; + p : TPropertyDefinition; + begin + if ( locClassPropNbr > 0 ) or ( locStoredPropsNbr > 0 ) then begin + NewLine(); + WriteLn('{ %s }',[ASymbol.Name]); + + if ( locClassPropNbr > 0 ) then begin + NewLine(); + WriteLn('destructor %s.Destroy();',[ASymbol.Name]); + WriteLn('begin'); + IncIndent(); + for k := 0 to Pred(ASymbol.PropertyCount) do begin + p := ASymbol.Properties[k]; + if p.DataType.InheritsFrom(TClassTypeDefinition) then begin + Indent(); + WriteLn('if Assigned(F%s) then',[p.Name]); + IncIndent(); + Indent(); + WriteLn('FreeAndNil(F%s);',[p.Name]) ; + DecIndent(); + end; + end; + Indent(); + WriteLn('inherited Destroy();'); + DecIndent(); + WriteLn('end;'); + end; + + if ( locStoredPropsNbr > 0 ) then begin + for k := 0 to Pred(ASymbol.PropertyCount) do begin + p := ASymbol.Properties[k]; + if ( p.StorageOption = soOptional ) then begin + NewLine(); + WriteLn('function %s.Has%s() : Boolean;',[ASymbol.Name,p.Name]); + WriteLn('begin'); + IncIndent(); + Indent(); + WriteLn('Result := True;'); + DecIndent(); + WriteLn('end;'); + end; + end; + end; + + end; + end; + +begin + Prepare(); + try + loc_BaseComplexSimpleContentRemotable := FSymbolTable.ByName('TBaseComplexSimpleContentRemotable') as TClassTypeDefinition; + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + WriteDec(); + WriteProperties(); + Indent(); WriteLn('end;'); + DecIndent(); + + FImpTempStream.Indent(); + FImpTempStream.WriteLn('GetTypeRegistry().Register(%s,TypeInfo(%s),%s);',[sNAME_SPACE,ASymbol.Name,QuotedStr(ASymbol.ExternalName)]); + + SetCurrentStream(FImpStream); + WriteImp(); + except + on e : Exception do + System.WriteLn('TInftGenerator.GenerateClass()=', ASymbol.Name, ' ;; ', e.Message); + end; +end; + +procedure TInftGenerator.GenerateEnum(ASymbol: TEnumTypeDefinition); +var + itm : TEnumItemDefinition; + i : Integer; +begin + try + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + Indent();WriteLn('%s = ( ',[ASymbol.Name]); + + FImpTempStream.Indent(); + FImpTempStream.WriteLn('GetTypeRegistry().Register(%s,TypeInfo(%s),%s);',[sNAME_SPACE,ASymbol.Name,QuotedStr(ASymbol.ExternalName)]); + + IncIndent(); + for i := 0 to Pred(ASymbol.ItemCount) do begin + itm := ASymbol.Item[i]; + Indent(); + if ( i > 0 ) then + WriteLn(',%s',[itm.Name]) + else + WriteLn('%s',[itm.Name]); + if not AnsiSameText(itm.Name,itm.ExternalName) then begin + FImpTempStream.Indent(); + FImpTempStream.WriteLn('GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);',[ASymbol.Name,QuotedStr(itm.Name),QuotedStr(itm.ExternalName)]); + end; + end; + DecIndent(); + Indent(); WriteLn(');'); + DecIndent(); + except + on e : Exception do + System.WriteLn('TInftGenerator.GenerateClass()=', ASymbol.Name, ' ;; ', e.Message); + end; +end; + +procedure TInftGenerator.GenerateArray(ASymbol: TArrayDefinition); + + procedure WriteObjectArray(); + begin + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + BeginAutoIndent(); + try + WriteLn('%s = class(TBaseObjectArrayRemotable)',[ASymbol.Name]); + WriteLn('private'); + Indent();WriteLn('function GetItem(AIndex: Integer): %s;',[ASymbol.ItemType.Name]); + WriteLn('public'); + Indent();WriteLn('class function GetItemClass():TBaseRemotableClass;override;'); + Indent();WriteLn('property Item[AIndex:Integer] : %s Read GetItem;Default;',[ASymbol.ItemType.Name]); + WriteLn('end;'); + finally + EndAutoIndent(); + DecIndent(); + end; + + SetCurrentStream(FImpStream); + NewLine(); + WriteLn('{ %s }',[ASymbol.Name]); + + NewLine(); + WriteLn('function %s.GetItem(AIndex: Integer): %s;',[ASymbol.Name,ASymbol.ItemType.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('Result := Inherited GetItem(AIndex) As %s;',[ASymbol.ItemType.Name]); + DecIndent(); + WriteLn('end;'); + + NewLine(); + WriteLn('class function %s.GetItemClass(): TBaseRemotableClass;',[ASymbol.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('Result:= %s;',[ASymbol.ItemType.Name]); + DecIndent(); + WriteLn('end;'); + end; + + procedure WriteSimpleTypeArray(); + begin + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + BeginAutoIndent(); + try + WriteLn('%s = class(TBaseSimpleTypeArrayRemotable)',[ASymbol.Name]); + WriteLn('private'); + Indent();WriteLn('FData : array of %s;',[ASymbol.ItemType.Name]); + WriteLn('private'); + Indent();WriteLn('function GetItem(AIndex: Integer): %s;',[ASymbol.ItemType.Name]); + Indent();WriteLn('procedure SetItem(AIndex: Integer; const AValue: %s);',[ASymbol.ItemType.Name]); + WriteLn('protected'); + Indent();WriteLn('function GetLength():Integer;override;'); + Indent();WriteLn('procedure SaveItem(AStore : IFormatterBase;const AName : String;const AIndex : Integer);override;'); + Indent();WriteLn('procedure LoadItem(AStore : IFormatterBase;const AIndex : Integer);override;'); + WriteLn('public'); + Indent();WriteLn('class function GetItemTypeInfo():PTypeInfo;override;'); + Indent();WriteLn('procedure SetLength(const ANewSize : Integer);override;'); + Indent();WriteLn('property Item[AIndex:Integer] : %s read GetItem write SetItem; default;',[ASymbol.ItemType.Name]); + WriteLn('end;'); + finally + EndAutoIndent(); + DecIndent(); + end; + + SetCurrentStream(FImpStream); + NewLine(); + WriteLn('{ %s }',[ASymbol.Name]); + + NewLine(); + WriteLn('function %s.GetItem(AIndex: Integer): %s;',[ASymbol.Name,ASymbol.ItemType.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('CheckIndex(AIndex);'); + Indent();WriteLn('Result := FData[AIndex];'); + DecIndent(); + WriteLn('end;'); + + NewLine(); + WriteLn('procedure %s.SetItem(AIndex: Integer;const AValue: %S);',[ASymbol.Name,ASymbol.ItemType.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('CheckIndex(AIndex);'); + Indent();WriteLn('FData[AIndex] := AValue;'); + DecIndent(); + WriteLn('end;'); + + NewLine(); + WriteLn('function %s.GetLength(): Integer;',[ASymbol.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('Result := System.Length(FData);'); + DecIndent(); + WriteLn('end;'); + + NewLine(); + WriteLn('procedure %s.SaveItem(AStore: IFormatterBase;const AName: String; const AIndex: Integer);',[ASymbol.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('AStore.Put(%s,TypeInfo(%s),FData[AIndex]);',[QuotedStr(ASymbol.ItemName),ASymbol.ItemType.Name]); + DecIndent(); + WriteLn('end;'); + + NewLine(); + IncIndent(); + WriteLn('procedure %s.LoadItem(AStore: IFormatterBase;const AIndex: Integer);',[ASymbol.Name]); + WriteLn('var'); + Indent();WriteLn('sName : string;'); + WriteLn('begin'); + Indent();WriteLn('sName := %s;',[QuotedStr(ASymbol.ItemName)]); + Indent();WriteLn('AStore.Get(TypeInfo(%s),sName,FData[AIndex]);',[ASymbol.ItemType.Name]); + DecIndent(); + WriteLn('end;'); + + NewLine(); + WriteLn('class function %s.GetItemTypeInfo(): PTypeInfo;',[ASymbol.Name]); + WriteLn('begin'); + IncIndent(); + Indent();WriteLn('Result := TypeInfo(%s);',[ASymbol.ItemType.Name]); + DecIndent(); + WriteLn('end;'); + + NewLine(); + IncIndent(); + WriteLn('procedure %s.SetLength(const ANewSize: Integer);',[ASymbol.Name]); + WriteLn('var'); + Indent();WriteLn('i : Integer;'); + WriteLn('begin'); + Indent();WriteLn('if ( ANewSize < 0 ) then'); + Indent();Indent();WriteLn('i := 0'); + Indent();WriteLn('else'); + Indent();Indent();WriteLn('i := ANewSize;'); + Indent();WriteLn('System.SetLength(FData,i);'); + DecIndent(); + WriteLn('end;'); + end; + +var + classItemArray : Boolean; +begin + classItemArray := ( ASymbol.ItemType is TClassTypeDefinition ) or + ( ASymbol.ItemType is TArrayDefinition ) ; + + if classItemArray then begin + WriteObjectArray(); + end else begin + WriteSimpleTypeArray(); + end; + + FImpTempStream.Indent(); + FImpTempStream.WriteLn('GetTypeRegistry().Register(%s,TypeInfo(%s),%s);',[sNAME_SPACE,ASymbol.Name,QuotedStr(ASymbol.ExternalName)]); +end; + +function TInftGenerator.GetDestUnitName(): string; +begin + Result := Format('%s_intf',[SymbolTable.Name]); +end; + +constructor TInftGenerator.Create( + ASymTable : TSymbolTable; + ASrcMngr : ISourceManager +); +begin + inherited Create(ASymTable,ASrcMngr); + FDecStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec'); + FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp'); + FImpTempStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp'); + FImpTempStream.IncIndent(); +end; + +procedure TInftGenerator.Execute(); +var + i,c, j, k : Integer; + clssTyp : TClassTypeDefinition; + gnrClssLst : TObjectList; + objLst : TObjectList; +begin + objLst := nil; + gnrClssLst := TObjectList.Create(False); + try + GenerateUnitHeader(); + GenerateUnitImplementationHeader(); + c := Pred(SymbolTable.Count); + + SetCurrentStream(FDecStream); + IncIndent(); + for i := 0 to c do begin + if SymbolTable.Item[i] is TForwardTypeDefinition then begin + WriteLn('// %s = unable to resolve this symbol.',[SymbolTable.Item[i].Name]); + end; + end; + DecIndent(); + + IncIndent(); + for i := 0 to c do begin + if ( SymbolTable.Item[i] is TClassTypeDefinition ) or + ( SymbolTable.Item[i] is TArrayDefinition ) + then begin + Indent(); + WriteLn('%s = class;',[SymbolTable.Item[i].Name]); + end; + end; + DecIndent(); + + for i := 0 to c do begin + if SymbolTable.Item[i] is TEnumTypeDefinition then begin + GenerateEnum(SymbolTable.Item[i] as TEnumTypeDefinition); + end; + end; + + for i := 0 to c do begin + if SymbolTable.Item[i] is TTypeAliasDefinition then begin + GenerateTypeAlias(SymbolTable.Item[i] as TTypeAliasDefinition); + end; + end; + + objLst := TObjectList.Create(); + objLst.OwnsObjects := False; + for i := 0 to c do begin + if SymbolTable.Item[i].InheritsFrom(TClassTypeDefinition) then begin + clssTyp := SymbolTable.Item[i] as TClassTypeDefinition; + if ( gnrClssLst.IndexOf(clssTyp) = -1 ) then begin + while ( objLst.Count > 0 ) do begin + objLst.Clear(); + end; + while Assigned(clssTyp) do begin + objLst.Add(clssTyp); + if Assigned(clssTyp.Parent) and clssTyp.Parent.InheritsFrom(TClassTypeDefinition) then begin + clssTyp := clssTyp.Parent as TClassTypeDefinition; + end else begin + clssTyp := nil; + end; + end; + + k := Pred(objLst.Count); + for j := 0 to k do begin + clssTyp := objLst[k-j] as TClassTypeDefinition; + if ( gnrClssLst.IndexOf(clssTyp) = -1 ) then begin + if ( FSymbolTable.IndexOf(clssTyp) <> -1 ) then begin + GenerateClass(clssTyp); + gnrClssLst.Add(clssTyp); + end; + end; + end; + end; + end; + end; + + for i := 0 to c do begin + if SymbolTable.Item[i] is TArrayDefinition then begin + GenerateArray(SymbolTable.Item[i] as TArrayDefinition); + end; + end; + + for i := 0 to c do begin + if SymbolTable.Item[i] is TInterfaceDefinition then begin + GenerateIntf(SymbolTable.Item[i] as TInterfaceDefinition); + end; + end; + + GenerateUnitImplementationFooter(); + FSrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FImpStream,FImpTempStream]); + FDecStream := nil; + FImpStream := nil; + FImpTempStream := nil; + finally + FreeAndNil(objLst); + FreeAndNil(gnrClssLst); + end; +end; + end. diff --git a/wst/trunk/ws_helper/parserdefs.pas b/wst/trunk/ws_helper/parserdefs.pas index 2e4412eb4..eca1a402f 100644 --- a/wst/trunk/ws_helper/parserdefs.pas +++ b/wst/trunk/ws_helper/parserdefs.pas @@ -32,31 +32,146 @@ Type ESymbolException = class(Exception) End; + TSymbolTable = class; + TTypeDefinition = class; + TForwardTypeDefinition = class; + { TAbstractSymbolDefinition } TAbstractSymbolDefinition = class private FName: String; + FExternalAlias : string; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );virtual; Public constructor Create(Const AName : String); + procedure RegisterExternalAlias(const AExternalName : String); + function SameName(const AName : string) : Boolean;virtual; Property Name : String Read FName; + Property ExternalName : String Read FExternalAlias; End; + TAbstractSymbolDefinitionClass = class of TAbstractSymbolDefinition; + + TPascalTokenDefinition = class(TAbstractSymbolDefinition) + end; + + TSymbolTableChange = ( stcAdding, stcDeleting ); + ISymbolTableChangeListner = interface + ['{0147E0EE-FF1A-4CFA-BD71-3F8E90494EC9}'] + procedure NotifyChange( + ASender : TSymbolTable; + AItem : TAbstractSymbolDefinition; + const AEvent : TSymbolTableChange + ); + end; + + { TAbstractConstantDefinition } + + TAbstractConstantDefinition = class(TAbstractSymbolDefinition) end; + + TSimpleConstantType = ( sctString, sctInteger ); + TSimpleConstantBuffer = record + case DataType : TSimpleConstantType of + sctInteger : ( IntValue : Integer; ); + sctString : ( StrValue : string[255]; ); + end; + + { TSimpleConstantDefinition } + + TSimpleConstantDefinition = class(TAbstractConstantDefinition) + private + FValue: TSimpleConstantBuffer; + public + constructor Create(const AName : string; const AValue : string);overload; + constructor Create(const AName : string; const AValue : Integer);overload; + property Value : TSimpleConstantBuffer read FValue; + end; + { TTypeDefinition } TTypeDefinition = class(TAbstractSymbolDefinition) public function NeedFinalization():Boolean;virtual; end; + + TAnyTypeDefinition = class(TTypeDefinition) + end; + { TTypeAliasDefinition } + + TTypeAliasDefinition = class(TTypeDefinition) + private + FBaseType: TTypeDefinition; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; + public + constructor Create(const AName : string; ABaseType : TTypeDefinition); + property BaseType : TTypeDefinition read FBaseType; + end; + + { TSimpleTypeDefinition } + + TSimpleTypeDefinition = class(TTypeDefinition) + public + function NeedFinalization():Boolean;override; + end; + + { TForwardTypeDefinition } + + TForwardTypeDefinition = class(TTypeDefinition) + end; + + { TArrayDefinition } + + TArrayDefinition = class(TTypeDefinition) + private + FItemName: string; + FItemType: TTypeDefinition; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; + public + constructor Create( + const AName : string; + AItemType : TTypeDefinition; + ItemName : string + ); + function NeedFinalization():Boolean;override; + property ItemName : string read FItemName; + property ItemType : TTypeDefinition read FItemType; + end; + + TEnumTypeDefinition = class; + { TEnumItemDefinition } TEnumItemDefinition = class(TAbstractSymbolDefinition) private + FEnumType: TEnumTypeDefinition; FOrder: Integer; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; Public - constructor Create(Const AName : String; Const AOrder : Integer); + constructor Create( + Const AName : String; + AEnumType : TEnumTypeDefinition; + Const AOrder : Integer + ); Property Order : Integer Read FOrder; + property EnumType : TEnumTypeDefinition read FEnumType; End; { TEnumTypeDefinition } @@ -77,13 +192,73 @@ Type Property Item[Index:Integer]:TEnumItemDefinition Read GetItem; End; + TStorageOption = ( soAlways, soOptional, soNever ); + + { TPropertyDefinition } + + TPropertyDefinition = class(TAbstractSymbolDefinition) + private + FDataType: TTypeDefinition; + FIsAttribute: Boolean; + FStorageOption: TStorageOption; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; + public + constructor Create( + Const AName : String; + ADataType : TTypeDefinition + ); + property DataType : TTypeDefinition Read FDataType; + property IsAttribute : Boolean read FIsAttribute write FIsAttribute; + property StorageOption : TStorageOption read FStorageOption write FStorageOption; + End; + { TClassTypeDefinition } TClassTypeDefinition = class(TTypeDefinition) + private + FParent: TTypeDefinition; + FPropertyList : TObjectList; + private + function GetProperty(const Index : Integer): TPropertyDefinition; + function GetPropertyCount: Integer; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; public + constructor Create(Const AName : String); + destructor Destroy();override; function NeedFinalization():Boolean;override; + function IsDescendantOf(ABaseType : TTypeDefinition) : Boolean; + procedure SetParent(const AValue: TTypeDefinition); + function AddProperty( + Const AName : String; + ADataType : TTypeDefinition + ) : TPropertyDefinition; + function IndexOfProperty(const AName : string):Integer; + property Parent : TTypeDefinition read FParent; + property PropertyCount : Integer read GetPropertyCount; + property Properties[const Index : Integer] : TPropertyDefinition read GetProperty; end; + TNativeClassTypeDefinition = class(TClassTypeDefinition) + end; + + { TNativeSimpleTypeDefinition } + + TNativeSimpleTypeDefinition = class(TSimpleTypeDefinition) + private + FBoxedType: TNativeClassTypeDefinition; + public + procedure SetBoxedType(ABoxedType : TNativeClassTypeDefinition); + property BoxedType : TNativeClassTypeDefinition read FBoxedType; + end; + TParameterModifier = ( pmNone, pmConst, pmVar, pmOut ); { TParameterDefinition } @@ -92,6 +267,12 @@ Type private FDataType: TTypeDefinition; FModifier: TParameterModifier; + protected + procedure SetModifier(const AModifier : TParameterModifier); + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; Public constructor Create( Const AName : String; @@ -114,8 +295,15 @@ Type private FMethodType: TMethodType; FParameterList : TObjectList; + private function GetParameter(Index: Integer): TParameterDefinition; function GetParameterCount: Integer; + protected + procedure SetMethodType( AMethodType : TMethodType ); + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; Public constructor Create(Const AName : String; Const AMethodType : TMethodType); destructor Destroy();override; @@ -137,8 +325,14 @@ Type Private FInterfaceGUID: string; FMethodList : TObjectList; + private function GetMethod(Index: Integer): TMethodDefinition; function GetMethodCount: Integer; + protected + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; Public constructor Create(Const AName : String); destructor Destroy();override; @@ -148,6 +342,7 @@ Type Const AName : String; Const AMethodType : TMethodType ):TMethodDefinition; + function AddMethod(AMthd : TMethodDefinition):TMethodDefinition; Property MethodCount : Integer Read GetMethodCount; Property Method[Index:Integer] : TMethodDefinition Read GetMethod; property InterfaceGUID : string read FInterfaceGUID write FInterfaceGUID; @@ -158,37 +353,130 @@ Type TSymbolTable = class(TAbstractSymbolDefinition) Private FList : TObjectList; + FLinkedTables : TObjectList; + FListners : IInterfaceList; + private procedure CheckIndex(Const AIndex : Integer); function GetCount: Integer; function GetItem(Index: Integer): TAbstractSymbolDefinition; + function GetLinkedTableCount: Integer; + function GetLinkedTables(Index : Integer): TSymbolTable; procedure SetName(const AValue: String); + procedure ReorderClass(ASym : TClassTypeDefinition); + protected + procedure NotifyChange( + ASender : TSymbolTable; + AItem : TAbstractSymbolDefinition; + const AEvent : TSymbolTableChange + ); + procedure FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition + );override; Public constructor Create(Const AName : String); destructor Destroy();override; procedure Clear(); function Add(ASym : TAbstractSymbolDefinition):Integer; + procedure Delete(ASym : TAbstractSymbolDefinition); function IndexOf(Const AName : String):Integer;overload; + function IndexOf( + const AName : string; + const AMinClass : TAbstractSymbolDefinitionClass + ):Integer;overload; function IndexOf(ASym : TAbstractSymbolDefinition):Integer;overload; - function Find(Const AName : String):TAbstractSymbolDefinition; + function Find(Const AName : String):TAbstractSymbolDefinition;overload; + function Find( + const AName : string; + const AMinClass : TAbstractSymbolDefinitionClass + ):TAbstractSymbolDefinition;overload; function ByName(Const AName : String):TAbstractSymbolDefinition; + procedure RegisterListner(AListner : ISymbolTableChangeListner); + procedure UnregisterListner(AListner : ISymbolTableChangeListner); Property Name : String Read FName Write SetName; Property Count : Integer Read GetCount; - Property Item[Index:Integer] : TAbstractSymbolDefinition Read GetItem; + Property Item[Index:Integer] : TAbstractSymbolDefinition Read GetItem;default; + property LinkedTables[Index : Integer] : TSymbolTable read GetLinkedTables; + property LinkedTableCount : Integer read GetLinkedTableCount; End; + + //function CreateSystemSymbolTable() : TSymbolTable; + procedure AddSystemSymbol(ADest : TSymbolTable); + procedure AddSoapencSymbol(ADest : TSymbolTable); + function CreateWstInterfaceSymbolTable() : TSymbolTable; + function IsReservedKeyWord(const AValue : string):Boolean ; + implementation uses StrUtils, parserutils; +const LANGAGE_TOKEN : array[0..107] of string = ( + 'ABSTRACT', 'AND', 'ARRAY', 'AS', 'ASM', + 'BEGIN', 'BOOLEAN', 'BYTE', + 'CASE', 'CDECL', 'CHAR', 'CLASS', 'COMP', 'CONST', 'CONSTRUCTOR', 'CONTAINS', 'CURRENCY', + 'DEFAULT', 'DESTRUCTOR', 'DIV', 'DO', 'DOUBLE', 'DOWNTO', 'DYNAMIC', + 'END', 'EXPORT', 'EXPORTS', 'EXTERNAL', + 'FAR', 'FILE', 'FINALLY', 'FOR', 'FORWARD', 'FUNCTION', 'GOTO', + 'ELSE', 'EXCEPT', 'EXTENDED', + 'IF', 'IMPLEMENTATION', 'IMPLEMENTS', 'IN', 'INHERITED', 'INT64', 'INITIALIZATION', + 'INTEGER', 'INTERFACE', 'IS', + 'LABEL', 'LIBRARY', 'LOCAL', 'LONGINT', 'LONGWORD', + 'MOD', 'NEAR', 'NIL', 'NODEFAULT', 'NOT', + 'OBJECT', 'OF', 'OLEVARIANT', 'OR', 'OUT', 'OVERLOAD', 'OVERRIDE', + 'PACKAGE', 'PACKED', 'PASCAL', 'PCHAR', 'PRIVATE', 'PROCEDURE', 'PROGRAM', 'PUBLISHED', + 'RAISE', 'READ', 'REAL', 'RECORD', 'REGISTER', 'REINTRODUCE', 'REPEAT', 'REQUIRES', 'RESULT', + 'SAFECALL', 'SET', 'SHL', 'SHORTINT', 'SHR', 'SINGLE', 'SMALLINT', 'STDCALL', 'STORED', + 'THEN', 'TO', 'TRY', 'TYPE', 'UNIT', 'UNTIL', 'USES', + 'VAR', 'VARARGS', 'VARIANT', 'VIRTUAL', 'WHILE', 'WIDECHAR', 'WITH', 'WORD', 'WRITE', 'XOR' +); +function IsReservedKeyWord(const AValue : string):Boolean ; +begin + Result := AnsiMatchText(AValue,LANGAGE_TOKEN); +end; + { TAbstractSymbolDefinition } constructor TAbstractSymbolDefinition.Create(const AName: String); begin Assert(Not IsStrEmpty(AName)); FName := AName; + FExternalAlias := FName; +end; + +procedure TAbstractSymbolDefinition.RegisterExternalAlias(const AExternalName : String); +begin + FExternalAlias := AExternalName; +end; + +function TAbstractSymbolDefinition.SameName(const AName: string): Boolean; +begin + Result := AnsiSameText(AName,Self.Name) or AnsiSameText(AName,Self.ExternalName); +end; + +procedure TAbstractSymbolDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +begin + end; { TParameterDefinition } +procedure TParameterDefinition.SetModifier(const AModifier: TParameterModifier); +begin + FModifier := AModifier; +end; + +procedure TParameterDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +begin + if ( FDataType = AFrw ) then + FDataType := Atype; +end; + constructor TParameterDefinition.Create( const AName: String; const AModifier: TParameterModifier; @@ -213,6 +501,22 @@ begin Result := FParameterList.Count; end; +procedure TMethodDefinition.SetMethodType(AMethodType: TMethodType); +begin + FMethodType := AMethodType; +end; + +procedure TMethodDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +var + i : Integer; +begin + for i := 0 to Pred(ParameterCount) do + Parameter[i].FixForwardTypeDefinitions(AFrw, Atype); +end; + constructor TMethodDefinition.Create( const AName: String; const AMethodType: TMethodType @@ -276,6 +580,17 @@ begin Result := FMethodList.Count; end; +procedure TInterfaceDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +var + i : Integer; +begin + for i := 0 to Pred(MethodCount) do + Method[i].FixForwardTypeDefinitions(AFrw, Atype); +end; + constructor TInterfaceDefinition.Create(const AName: String); begin Inherited Create(AName); @@ -312,12 +627,21 @@ function TInterfaceDefinition.AddMethod( Const AMethodType : TMethodType ):TMethodDefinition; begin - If ( GetMethodIndex(Name) = -1 ) Then Begin - Result := TMethodDefinition.Create(AName,AMethodType); + if ( GetMethodIndex(Name) = -1 ) then begin + Result := AddMethod(TMethodDefinition.Create(AName,AMethodType)); + end else begin + raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AName]); + end; +end; + +function TInterfaceDefinition.AddMethod(AMthd: TMethodDefinition): TMethodDefinition; +begin + if ( GetMethodIndex(AMthd.Name) = -1 ) then begin + Result := AMthd; FMethodList.Add(Result); - End Else Begin - Raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AName]); - End; + end else begin + raise ESymbolException.CreateFmt('Duplicated methode : %s.%s',[Name,AMthd.Name]); + end; end; { TSymbolTable } @@ -339,47 +663,166 @@ begin Result := FList[Index] As TAbstractSymbolDefinition; end; +function TSymbolTable.GetLinkedTableCount: Integer; +begin + Result := FLinkedTables.Count; +end; + +function TSymbolTable.GetLinkedTables(Index : Integer): TSymbolTable; +begin + Result := FLinkedTables[Index] as TSymbolTable; +end; + procedure TSymbolTable.SetName(const AValue: String); begin - if ( FName = AValue ) then exit; + if ( FName = AValue ) then + Exit; FName := AValue; end; +procedure TSymbolTable.ReorderClass(ASym: TClassTypeDefinition); +var + i ,j : Integer; + locSymb : TClassTypeDefinition; +begin + locSymb := ASym; + while True do begin + if not Assigned(locSymb.Parent) then + Exit; + i := FList.IndexOf(locSymb); + if ( i < 0 ) then + Exit; + j := FList.IndexOf(locSymb.Parent); + if ( j < 0 ) then + Exit; + //if ( i > j ) then + //Exit; + if ( i < j ) then + FList.Exchange(i,j); + if not locSymb.Parent.InheritsFrom(TClassTypeDefinition) then + Exit; + locSymb := locSymb.Parent as TClassTypeDefinition; + end; +end; + +procedure TSymbolTable.NotifyChange( + ASender : TSymbolTable; + AItem : TAbstractSymbolDefinition; + const AEvent : TSymbolTableChange +); +var + i : Integer; +begin + for i := 0 to Pred(FListners.Count) do + (FListners[i] as ISymbolTableChangeListner).NotifyChange(ASender,AItem,AEvent); +end; + +procedure TSymbolTable.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +var + i : Integer; +begin + for i := 0 to Pred(Count) do + Item[i].FixForwardTypeDefinitions(AFrw, Atype); +end; + constructor TSymbolTable.Create(Const AName : String); begin Inherited Create(AName); FList := TObjectList.Create(True); + FLinkedTables := TObjectList.Create(False); + FListners := TInterfaceList.Create(); end; destructor TSymbolTable.Destroy(); begin - FList.Free(); + if Assigned(FList) then + Clear(); + FreeAndNil(FList); + FreeAndNil(FLinkedTables); + FListners := nil; inherited Destroy(); end; procedure TSymbolTable.Clear(); +var + i : Integer; begin - FList.Clear(); + FLinkedTables.Clear(); + for i := 0 to Pred(FList.Count) do + Delete(FList[0] as TAbstractSymbolDefinition); end; function TSymbolTable.Add(ASym: TAbstractSymbolDefinition): Integer; +var + i : Integer; + locNeedFix : Boolean; + frwdTyp : TForwardTypeDefinition; begin Result := IndexOf(ASym); If ( Result = -1 ) Then Begin - If ( IndexOf(ASym.Name) <> -1 ) Then - Raise ESymbolException.CreateFmt('Duplicated symbol name : %s',[ASym.Name]); + locNeedFix := False; + i := IndexOf(ASym.Name); + if ( i <> -1 ) then begin + if Item[i].InheritsFrom(TForwardTypeDefinition) and + ( not ASym.InheritsFrom(TForwardTypeDefinition) ) + then + locNeedFix := True + else + raise ESymbolException.CreateFmt('Duplicated symbol name : %s',[ASym.Name]); + end; + NotifyChange(Self,ASym,stcAdding); Result := FList.Add(ASym); + if ASym.InheritsFrom(TSymbolTable) then + FLinkedTables.Add(ASym); + if locNeedFix then begin + frwdTyp := Item[i] as TForwardTypeDefinition; + FixForwardTypeDefinitions( frwdTyp, (ASym as TTypeDefinition ) ); + FList.Exchange(i,Result); + Delete(frwdTyp); + end; + Result := IndexOf(ASym); End; end; +procedure TSymbolTable.Delete(ASym: TAbstractSymbolDefinition); +var + i : Integer; +begin + if Assigned(ASym) then begin + i := FList.IndexOf(ASym); + if ( i >= 0 ) then begin + NotifyChange(Self,ASym,stcDeleting); + FList.Delete(i); + end; + end; +end; + function TSymbolTable.IndexOf(const AName: String): Integer; begin - For Result := 0 To Pred(Count) Do - If AnsiSameText(AName,Item[Result].Name) Then + for Result := 0 to Pred(Count) do + if Item[Result].SameName(AName) then Exit; Result := -1; end; +function TSymbolTable.IndexOf( + const AName : string; + const AMinClass : TAbstractSymbolDefinitionClass +): Integer; +var + syb : TAbstractSymbolDefinition; +begin + for Result := 0 to Pred(Count) do begin + syb := Item[Result]; + if syb.SameName(AName) and syb.InheritsFrom(AMinClass) then + Exit; + end; + Result := -1; +end; + function TSymbolTable.IndexOf(ASym: TAbstractSymbolDefinition): Integer; begin Result := FList.IndexOf(ASym); @@ -390,10 +833,36 @@ Var i : Integer; begin i := IndexOf(AName); - If ( i > -1 ) Then + if ( i > -1 ) then begin Result := Item[i] - Else + end else begin + for i := 0 to Pred(LinkedTableCount) do begin + Result := LinkedTables[i].Find(AName); + if Assigned(Result) then + Exit; + end; Result := Nil; + end; +end; + +function TSymbolTable.Find( + const AName : string; + const AMinClass : TAbstractSymbolDefinitionClass +): TAbstractSymbolDefinition; +var + i : Integer; +begin + i := IndexOf(AName,AMinClass); + if ( i > -1 ) then begin + Result := Item[i] + end else begin + for i := 0 to Pred(LinkedTableCount) do begin + Result := LinkedTables[i].Find(AName,AMinClass); + if Assigned(Result) then + Exit; + end; + Result := Nil; + end; end; function TSymbolTable.ByName(const AName: String): TAbstractSymbolDefinition; @@ -403,12 +872,39 @@ begin Raise ESymbolException.CreateFmt('No such Symbol : %s',[AName]); end; +procedure TSymbolTable.RegisterListner(AListner: ISymbolTableChangeListner); +begin + if Assigned(AListner) and ( FListners.IndexOf(AListner) < 0 ) then + FListners.Add(AListner); +end; + +procedure TSymbolTable.UnregisterListner(AListner: ISymbolTableChangeListner); +begin + if Assigned(AListner) and ( FListners.IndexOf(AListner) >= 0 ) then + FListners.Remove(AListner); +end; + { TEnumItemDefinition } -constructor TEnumItemDefinition.Create(const AName: String; Const AOrder: Integer); +procedure TEnumItemDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); begin - Inherited Create(AName); + if ( TObject(AFrw) = TObject(FEnumType) ) then + FEnumType := Atype as TEnumTypeDefinition; +end; + +constructor TEnumItemDefinition.Create( + const AName : string; + AEnumType : TEnumTypeDefinition; + const AOrder : Integer +); +begin + Assert(Assigned(AEnumType)); + inherited Create(AName); FOrder := AOrder; + FEnumType := AEnumType; end; { TEnumTypeDefinition } @@ -461,21 +957,336 @@ begin end; { TTypeDefinition } -const SIMPLE_TYPES : Array[0..12] Of string = ( - 'string', 'integer', 'smallint', 'shortint', 'char', 'boolean', - 'byte', 'word', 'longint', 'int64', - 'single', 'double', 'extended' +const SIMPLE_TYPES : Array[0..14] Of array[0..2] of string = ( + ('string', 'TComplexStringContentRemotable', 'string'), + ('integer', 'TComplexInt32SContentRemotable', 'int'), + ('LongWord', 'TComplexInt32UContentRemotable', 'unsignedInt' ), + ('SmallInt', 'TComplexInt16SContentRemotable', 'short'), + ('ShortInt', 'TComplexInt8SContentRemotable', 'byte'), + ('char', '', ''), + ('boolean', 'TComplexBooleanContentRemotable', 'boolean'), + ('Byte', 'TComplexInt8UContentRemotable', 'unsignedByte'), + ('Word', 'TComplexInt16UContentRemotable', 'unsignedShort'), + ('Longint', 'TComplexInt32SContentRemotable', 'int'), + ('Int64', 'TComplexInt64SContentRemotable', 'long'), + ('Qword', 'TComplexInt64UContentRemotable', 'unsignedLong'), + ('Single', 'TComplexFloatSingleContentRemotable', 'single'), + ('Double', 'TComplexFloatDoubleContentRemotable', 'double'), + ('Extended', 'TComplexFloatExtendedContentRemotable', 'decimal') ); + function TTypeDefinition.NeedFinalization(): Boolean; +var + i : Integer; begin - Result := ( AnsiIndexText(Name,SIMPLE_TYPES) = -1 ); + for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin + if AnsiSameText(SIMPLE_TYPES[i][0],Name) then begin + Result := True; + Exit; + end; + end; + Result := False; end; { TClassTypeDefinition } +procedure TClassTypeDefinition.SetParent(const AValue: TTypeDefinition); +begin + if ( AValue = Self ) then begin + raise ESymbolException.Create('A class can not be its parent.'); + end; + if ( FParent = AValue ) then begin + Exit; + end; + FParent := AValue; +end; + +function TClassTypeDefinition.AddProperty( + const AName : String; + ADataType : TTypeDefinition +): TPropertyDefinition; +var + i : Integer; +begin + if not Assigned(ADataType) then + raise ESymbolException.CreateFmt('Property data type not provided : "%s".',[AName]); + i := IndexOfProperty(AName); + if ( i = -1 ) then + i := FPropertyList.Add(TPropertyDefinition.Create(AName,ADataType)); + Result := FPropertyList[i] as TPropertyDefinition; +end; + +function TClassTypeDefinition.IndexOfProperty(const AName: string): Integer; +begin + for Result := 0 to Pred(PropertyCount) do begin + if AnsiSameText(AName,Properties[Result].Name) then + Exit; + end; + Result := -1; +end; + +function TClassTypeDefinition.GetProperty(const Index : Integer): TPropertyDefinition; +begin + Result := FPropertyList[Index] as TPropertyDefinition; +end; + +function TClassTypeDefinition.GetPropertyCount: Integer; +begin + Result := FPropertyList.Count; +end; + +procedure TClassTypeDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +var + i : Integer; +begin + if ( FParent = AFrw ) then + FParent := Atype; + for i := 0 to Pred(PropertyCount) do begin + Properties[i].FixForwardTypeDefinitions(AFrw,Atype); + end; +end; + +constructor TClassTypeDefinition.Create(const AName: String); +begin + inherited Create(AName); + FPropertyList := TObjectList.Create(True); +end; + +destructor TClassTypeDefinition.Destroy(); +begin + FreeAndNil(FPropertyList); + inherited Destroy(); +end; + function TClassTypeDefinition.NeedFinalization(): Boolean; begin Result := True; end; +function TClassTypeDefinition.IsDescendantOf(ABaseType: TTypeDefinition): Boolean; +var + tmpDef : TTypeDefinition; +begin + tmpDef := Self; + while Assigned(tmpDef) do begin + if ( tmpDef = ABaseType ) then begin + Result := True; + Exit; + end; + if tmpDef is TClassTypeDefinition then begin + tmpDef := (tmpDef as TClassTypeDefinition).Parent; + end else begin + tmpDef := nil; + end; + end; + Result := False; +end; + + +{ TPropertyDefinition } + +procedure TPropertyDefinition.FixForwardTypeDefinitions( + AFrw : TForwardTypeDefinition; + Atype : TTypeDefinition +); +begin + if ( FDataType = AFrw ) then + FDataType := Atype; +end; + +constructor TPropertyDefinition.Create( + const AName : String; + ADataType : TTypeDefinition +); +begin + inherited Create(AName); + FDataType := ADataType; +end; + +{ TSimpleTypeDefinition } + +function TSimpleTypeDefinition.NeedFinalization(): Boolean; +begin + Result := False; +end; + +procedure AddSystemSymbol(ADest: TSymbolTable); +var + i : Integer; + splTyp : TNativeSimpleTypeDefinition; + syb : TNativeClassTypeDefinition; + s : string; +begin + for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin + splTyp := TNativeSimpleTypeDefinition.Create(SIMPLE_TYPES[i][0]); + ADest.Add(splTyp); + s := SIMPLE_TYPES[i][1]; + if not IsStrEmpty(s) then begin + syb := ADest.Find(SIMPLE_TYPES[i][1]) as TNativeClassTypeDefinition; + if not Assigned(syb) then begin + syb := TNativeClassTypeDefinition.Create(SIMPLE_TYPES[i][1]); + end; + ADest.Add(syb); + //syb.RegisterExternalAlias(SIMPLE_TYPES[i][2]); + splTyp.SetBoxedType(syb); + end; + end; + for i := Low(SIMPLE_TYPES) to High(SIMPLE_TYPES) do begin + splTyp := ADest.ByName(SIMPLE_TYPES[i][0]) as TNativeSimpleTypeDefinition; + if not IsStrEmpty(SIMPLE_TYPES[i][2]) then begin + splTyp.RegisterExternalAlias(SIMPLE_TYPES[i][2]); + end; + end; +end; + +procedure AddSoapencSymbol(ADest: TSymbolTable); +var + locSymTable : TSymbolTable; +begin + locSymTable := TSymbolTable.Create('soapenc'); + ADest.Add(locSymTable); + locSymTable.RegisterExternalAlias('http://schemas.xmlsoap.org/soap/encoding/'); + locSymTable.Add(TAnyTypeDefinition.Create('any')); +end; + +function CreateWstInterfaceSymbolTable() : TSymbolTable; + function AddClassDef( + ATable : TSymbolTable; + const AClassName, + AParentName : string + ):TClassTypeDefinition; + begin + Result := TClassTypeDefinition.Create(AClassName); + if not IsStrEmpty(AParentName) then + Result.SetParent(ATable.ByName(AParentName) as TClassTypeDefinition); + ATable.Add(Result); + end; + +var + loc_TBaseComplexSimpleContentRemotable : TClassTypeDefinition; + locTyp : TTypeDefinition; +begin + Result := TSymbolTable.Create('base_service_intf'); + try + AddSystemSymbol(Result); + AddClassDef(Result,'TBaseRemotable',''); + AddClassDef(Result,'TAbstractSimpleRemotable','TBaseRemotable'); + AddClassDef(Result,'TDateRemotable','TAbstractSimpleRemotable').RegisterExternalAlias('dateTime'); + AddClassDef(Result,'TDurationRemotable','TAbstractSimpleRemotable').RegisterExternalAlias('duration'); + + AddClassDef(Result,'TAbstractComplexRemotable','TBaseRemotable'); + loc_TBaseComplexSimpleContentRemotable := AddClassDef(Result,'TBaseComplexSimpleContentRemotable','TAbstractComplexRemotable'); + (Result.ByName('TComplexInt16SContentRemotable') as TClassTypeDefinition).SetParent(loc_TBaseComplexSimpleContentRemotable); + (Result.ByName('TComplexFloatDoubleContentRemotable') as TClassTypeDefinition).SetParent(loc_TBaseComplexSimpleContentRemotable); + + AddClassDef(Result,'TBaseComplexRemotable','TAbstractComplexRemotable'); + AddClassDef(Result,'THeaderBlock','TBaseComplexRemotable'); + AddClassDef(Result,'TBaseArrayRemotable','TAbstractComplexRemotable'); + AddClassDef(Result,'TBaseObjectArrayRemotable','TBaseArrayRemotable'); + AddClassDef(Result,'TBaseSimpleTypeArrayRemotable','TBaseArrayRemotable'); + AddClassDef(Result,'TArrayOfStringRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfBooleanRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt8URemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt8SRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt16SRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt16URemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt32URemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt32SRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt64SRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfInt64URemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfFloatSingleRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfFloatDoubleRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfFloatExtendedRemotable','TBaseSimpleTypeArrayRemotable'); + AddClassDef(Result,'TArrayOfFloatCurrencyRemotable','TBaseSimpleTypeArrayRemotable'); + + locTyp := TTypeAliasDefinition.Create('token',Result.ByName('string') as TTypeDefinition); + Result.Add(locTyp); + locTyp := TTypeAliasDefinition.Create('anyURI',Result.ByName('string') as TTypeDefinition); + Result.Add(locTyp); + locTyp := TTypeAliasDefinition.Create('float',Result.ByName('Single') as TTypeDefinition); + Result.Add(locTyp); + + locTyp := TTypeAliasDefinition.Create('base64Binary',Result.ByName('string') as TTypeDefinition); + Result.Add(locTyp); + + except //base64Binary + FreeAndNil(Result); + raise; + end; +end; + +{ TTypeAliasDefinition } + +procedure TTypeAliasDefinition.FixForwardTypeDefinitions( + AFrw: TForwardTypeDefinition; + Atype: TTypeDefinition +); +begin + if ( FBaseType = AFrw ) then + FBaseType := Atype; +end; + +constructor TTypeAliasDefinition.Create( + const AName : string; + ABaseType : TTypeDefinition +); +begin + Assert(Assigned(ABaseType)); + inherited Create(AName); + FBaseType := ABaseType; +end; + +{ TSimpleConstantDefinition } + +constructor TSimpleConstantDefinition.Create(const AName: string;const AValue: string); +begin + inherited Create(AName); + FValue.DataType := sctString; + FValue.StrValue := AValue; +end; + +constructor TSimpleConstantDefinition.Create(const AName: string;const AValue: Integer); +begin + inherited Create(AName); + FValue.DataType := sctInteger; + FValue.IntValue := AValue; +end; + +{ TArrayDefinition } + +procedure TArrayDefinition.FixForwardTypeDefinitions( + AFrw: TForwardTypeDefinition; + Atype: TTypeDefinition +); +begin + if ( FItemType = AFrw ) then + FItemType := Atype; +end; + +constructor TArrayDefinition.Create( + const AName : string; + AItemType : TTypeDefinition; + ItemName : string +); +begin + Assert(Assigned(AItemType)); + inherited Create(AName); + FItemType := AItemType; +end; + +function TArrayDefinition.NeedFinalization(): Boolean; +begin + Result := True; +end; + +{ TNativeSimpleTypeDefinition } + +procedure TNativeSimpleTypeDefinition.SetBoxedType(ABoxedType: TNativeClassTypeDefinition); +begin + FBoxedType := ABoxedType; +end; + end. diff --git a/wst/trunk/ws_helper/test_CALCULATOR.bat b/wst/trunk/ws_helper/test_CALCULATOR.bat new file mode 100644 index 000000000..7c236a7e1 --- /dev/null +++ b/wst/trunk/ws_helper/test_CALCULATOR.bat @@ -0,0 +1 @@ +C:\Programmes\lazarus\wst\ws_helper\ws_helper -u -i -p -b -a"C:\Programmes\lazarus\wst\tests\files" "C:\Programmes\lazarus\wst\tests\files\CALCULATOR.wsdl" >test_res_CALCULATOR.txt \ No newline at end of file diff --git a/wst/trunk/ws_helper/test_ebay.bat b/wst/trunk/ws_helper/test_ebay.bat new file mode 100644 index 000000000..bfc3dc979 --- /dev/null +++ b/wst/trunk/ws_helper/test_ebay.bat @@ -0,0 +1 @@ +C:\Programmes\lazarus\wst\ws_helper\ws_helper -u -i -p -b -a"C:\Programmes\lazarus\wst\tests\files" "C:\Programmes\lazarus\utils\eBayLast\eBayWSDL.WSDL" >test_res_eBayWSDL.txt \ No newline at end of file diff --git a/wst/trunk/ws_helper/test_googleSearch.bat b/wst/trunk/ws_helper/test_googleSearch.bat new file mode 100644 index 000000000..700e44eac --- /dev/null +++ b/wst/trunk/ws_helper/test_googleSearch.bat @@ -0,0 +1 @@ +C:\Programmes\lazarus\wst\ws_helper\ws_helper -u -i -p -b -a"C:\Programmes\lazarus\wst\tests\files" "C:\Programmes\lazarus\utils\googleapi\GoogleSearch.wsdl" >test_res_GoogleSearch.txt \ No newline at end of file diff --git a/wst/trunk/ws_helper/test_metadata.bat b/wst/trunk/ws_helper/test_metadata.bat new file mode 100644 index 000000000..1263aefa7 --- /dev/null +++ b/wst/trunk/ws_helper/test_metadata.bat @@ -0,0 +1 @@ +C:\Programmes\lazarus\wst\ws_helper\ws_helper -u -i -p -b -a"C:\Programmes\lazarus\wst\tests\files" "C:\Programmes\lazarus\wst\tests\files\metadata_service.wsdl" >test_res_metadata_service.txt \ No newline at end of file diff --git a/wst/trunk/ws_helper/ws_helper.lpi b/wst/trunk/ws_helper/ws_helper.lpi index a0b73563f..4a0c2d34c 100644 --- a/wst/trunk/ws_helper/ws_helper.lpi +++ b/wst/trunk/ws_helper/ws_helper.lpi @@ -12,6 +12,7 @@ + @@ -23,7 +24,7 @@ - + @@ -32,57 +33,67 @@ - + - - + + + + - - + + + + - - + + + - - - + + + + - - + + + + - - + + + + - + @@ -90,84 +101,84 @@ - + - + - + - + - + - + - - - + + + - + - + - + - + - - - + + + @@ -175,7 +186,7 @@ - + @@ -183,70 +194,70 @@ - + - + - + - + - + - + - + - + - + - + - + @@ -254,36 +265,240 @@ - + - - - + + + - + - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -292,7 +507,7 @@ - + @@ -306,6 +521,14 @@ + + + + + + + + @@ -313,40 +536,32 @@ - + - - + + - + - + - - - - - - - - - - - - - - - - - + + + + + + + + + diff --git a/wst/trunk/ws_helper/ws_helper.pas b/wst/trunk/ws_helper/ws_helper.pas index f5ae99404..6a7c62fcf 100644 --- a/wst/trunk/ws_helper/ws_helper.pas +++ b/wst/trunk/ws_helper/ws_helper.pas @@ -25,24 +25,32 @@ program ws_helper; uses Classes, SysUtils, wst_resources_utils, parserdefs, ws_parser, generator, parserutils, source_utils, - command_line_parser, metadata_generator, binary_streamer; + command_line_parser, metadata_generator, binary_streamer, + DOM, xmlread, wsdl2pas_imp; resourcestring - sUSAGE = 'ws_helper [-p] [-b] [-i] [-oPATH] inputFilename' + sNEW_LINE + + sUSAGE = 'ws_helper [-u] [-p] [-b] [-i] [-oPATH] inputFilename' + sNEW_LINE + + ' -u Generate the pascal translation of the WSDL input file ' + sNEW_LINE + ' -p Generate service proxy' + sNEW_LINE + ' -b Generate service binder' + sNEW_LINE + ' -i Generate service minimal implementation' + sNEW_LINE + - ' -o PATH Output directory' + sNEW_LINE; + ' -o PATH Relative output directory' + sNEW_LINE + + ' -a PATH Absolute output directory' + sNEW_LINE; sCOPYRIGHT = 'ws_helper, Web Service Toolkit 0.3 Copyright (c) 2006 by Inoussa OUEDRAOGO'; const sWST_META = 'wst_meta'; +type + TSourceFileType = ( sftPascal, sftWSDL ); + Var inFileName,outPath,errStr : string; srcMngr : ISourceManager; AppOptions : TComandLineOptions; NextParam : Integer; + sourceType : TSourceFileType; + symtable : TSymbolTable; function ProcessCmdLine():boolean; begin @@ -50,22 +58,83 @@ Var If ( NextParam <= Paramcount ) Then inFileName := ParamStr(NextParam); Result := FileExists(ExpandFileName(inFileName)); + if AnsiSameText(ExtractFileExt(inFileName),'.PAS') or + AnsiSameText(ExtractFileExt(inFileName),'.PP') + then begin + sourceType := sftPascal; + end else if AnsiSameText(ExtractFileExt(inFileName),'.WSDL') then begin + sourceType := sftWSDL; + end; If Result Then Begin If ( AppOptions = [] ) Then Include(AppOptions,cloProxy); End Else errStr := Format('File not Found : "%s"',[inFileName]); - outPath := ExtractFilePath(inFileName); - If ( cloOutPutDir in AppOptions ) Then Begin - outPath := outPath + Trim(GetOptionArg(cloOutPutDir)); - outPath := IncludeTrailingPathDelimiter(outPath); - End; + if ( cloOutPutDirAbsolute in AppOptions ) then begin + outPath := Trim(GetOptionArg(cloOutPutDirAbsolute)); + end else begin + outPath := ExtractFilePath(inFileName); + if ( cloOutPutDirRelative in AppOptions ) then begin + outPath := outPath + Trim(GetOptionArg(cloOutPutDirRelative)); + end; + end; + outPath := IncludeTrailingPathDelimiter(outPath); end; + function GenerateSymbolTable() : Boolean ; + + procedure ParsePascalFile(); + var + s : TFileStream; + p : TPascalParser; + begin + s := nil; + p := nil; + try + s := TFileStream.Create(inFileName,fmOpenRead); + p := TPascalParser.Create(s,symtable); + if not p.Parse() then + p.Error('"%s" at line %d',[p.ErrorMessage,p.SourceLine]); + finally + FreeAndNil(p); + FreeAndNil(s); + end; + end; + + procedure ParseWsdlFile(); + var + locDoc : TXMLDocument; + prsr : TWsdlParser; + begin + prsr := nil; + ReadXMLFile(locDoc,inFileName); + try + prsr := TWsdlParser.Create(locDoc,symtable); + prsr.Parse(); + finally + FreeAndNil(prsr); + FreeAndNil(locDoc); + end; + end; + + begin + try + WriteLn('Parsing the file : ', inFileName); + case sourceType of + sftPascal : ParsePascalFile(); + sftWSDL : ParseWsdlFile(); + end; + Result := True; + except + on e : Exception do begin + Result := False; + errStr := e.Message; + end; + end; + end; + function ProcessFile():Boolean; Var - p : TPascalParser; - s : TFileStream; mtdaFS: TMemoryStream; g : TBaseGenerator; mg : TMetadataGenerator; @@ -76,86 +145,98 @@ Var mtdaFS := nil; mg := nil; g := Nil; - s := Nil; - p := Nil; - Try - Try - s := TFileStream.Create(inFileName,fmOpenRead); - p := TPascalParser.Create(s); - If Not p.Parse() Then - p.Error(p.ErrorMessage); + try + try + if ( cloInterface in AppOptions ) then begin + WriteLn('Interface file generation...'); + g := TInftGenerator.Create(symtable,srcMngr); + g.Execute(); + FreeAndNil(g); + end; + If ( cloProxy in AppOptions ) Then Begin - g := TProxyGenerator.Create(p.SymbolTable,srcMngr); + WriteLn('Proxy file generation...'); + g := TProxyGenerator.Create(symtable,srcMngr); g.Execute(); FreeAndNil(g); End; - + If ( cloBinder in AppOptions ) Then Begin - g := TBinderGenerator.Create(p.SymbolTable,srcMngr); + WriteLn('Binder file generation...'); + g := TBinderGenerator.Create(symtable,srcMngr); g.Execute(); FreeAndNil(g); End; If ( cloImp in AppOptions ) Then Begin - g := TImplementationGenerator.Create(p.SymbolTable,srcMngr); + WriteLn('Implementation file generation...'); + g := TImplementationGenerator.Create(symtable,srcMngr); g.Execute(); FreeAndNil(g); End; if ( [cloBinder,cloProxy]*AppOptions <> [] ) then begin + WriteLn('Metadata file generation...'); mtdaFS := TMemoryStream.Create(); - mg := TMetadataGenerator.Create(p.SymbolTable,CreateBinaryWriter(mtdaFS)); + mg := TMetadataGenerator.Create(symtable,CreateBinaryWriter(mtdaFS)); mg.Execute(); mtdaFS.SaveToFile(ChangeFileExt(inFileName,'.' + sWST_META)); rsrcStrm := TMemoryStream.Create(); mtdaFS.Position := 0; - //BinaryToLazarusResourceCode(mtdaFS,rsrcStrm,UpperCase(p.SymbolTable.Name),sWST_META); - BinToWstRessource(UpperCase(p.SymbolTable.Name),mtdaFS,rsrcStrm); + BinToWstRessource(UpperCase(symtable.Name),mtdaFS,rsrcStrm); rsrcStrm.SaveToFile(outPath + ChangeFileExt(ExtractFileName(inFileName),'.' + sWST_EXTENSION)); end; Result := True; - Except - On E : Exception Do Begin + except + on E : Exception do begin Result := False; - errStr := Format('"%s" at line %d',[E.Message,p.SourceLine]) ; - End; - End; - Finally + errStr := E.Message; + end; + end; + finally rsrcStrm.Free(); mg.Free();; mtdaFS.Free();; g.Free(); - p.Free(); - s.Free(); - End; + end; end; begin - Try - Writeln(sCOPYRIGHT); - If ( ParamCount = 0 ) Then Begin - WriteLn(sUSAGE); - Exit; - End; + symtable := nil; + try + try + Writeln(sCOPYRIGHT); + If ( ParamCount = 0 ) Then Begin + WriteLn(sUSAGE); + Exit; + End; + if not ProcessCmdLine() then begin + WriteLn(errStr); + Exit; + end; + symtable := TSymbolTable.Create(ChangeFileExt(ExtractFileName(inFileName),'')); + srcMngr := CreateSourceManager(); - srcMngr := CreateSourceManager(); - If Not ProcessCmdLine() Then Begin - WriteLn(errStr); - Exit; - End; + if not GenerateSymbolTable() then begin + WriteLn(errStr); + Exit; + end; + + If Not ProcessFile() Then Begin + WriteLn(errStr); + Exit; + End; - If Not ProcessFile() Then Begin - WriteLn(errStr); - Exit; - End; - - srcMngr.SaveToFile(outPath); - WriteLn(Format('File "%s" parsed succesfully.',[inFileName])); - except - on e:exception Do - Writeln('Exception : ' + e.Message) + srcMngr.SaveToFile(outPath); + WriteLn(Format('File "%s" parsed succesfully.',[inFileName])); + except + on e:exception Do + Writeln('Exception : ' + e.Message) + end; + finally + FreeAndNil(symtable); end; end. diff --git a/wst/trunk/ws_helper/ws_parser.pas b/wst/trunk/ws_helper/ws_parser.pas index c15b56613..f711563c8 100644 --- a/wst/trunk/ws_helper/ws_parser.pas +++ b/wst/trunk/ws_helper/ws_parser.pas @@ -60,7 +60,7 @@ Type procedure ParseEnumType(Const AName : String); procedure ParseClassType(Const AName : String); public - constructor Create(AStream : TStream); + constructor Create(AStream : TStream; ASymbolTable : TSymbolTable); destructor Destroy();override; procedure Error(Const AMsg : String);overload; procedure Error(Const AMsg : String; Const AArgs : Array of const);overload; @@ -417,7 +417,7 @@ begin tmpStr := Tokenizer.TokenString; If ( FSymbolTable.IndexOf(tmpStr) > -1 ) Then Error('Duplicated symbol : "%s"',[tmpStr]); - sblItem := TEnumItemDefinition.Create(tmpStr,tmpInt); + sblItem := TEnumItemDefinition.Create(tmpStr,sbl,tmpInt); FSymbolTable.Add(sblItem); sbl.AddItem(sblItem); NextToken(); @@ -451,19 +451,19 @@ begin NextToken(); end; -constructor TPascalParser.Create(AStream : TStream); +constructor TPascalParser.Create(AStream : TStream; ASymbolTable : TSymbolTable); begin Assert(Assigned(AStream)); + Assert(Assigned(ASymbolTable)); FStream := AStream; FTokenizer := TParser.Create(FStream); - FSymbolTable := TSymbolTable.Create('tmp_name'); + FSymbolTable := ASymbolTable; FCurrentSymbol := Nil; end; destructor TPascalParser.Destroy(); begin FTokenizer.Free(); - FreeAndNil(FSymbolTable); inherited Destroy(); end; diff --git a/wst/trunk/ws_helper/wsdl2pas_imp.pas b/wst/trunk/ws_helper/wsdl2pas_imp.pas new file mode 100644 index 000000000..5d00f9b48 --- /dev/null +++ b/wst/trunk/ws_helper/wsdl2pas_imp.pas @@ -0,0 +1,1924 @@ +unit wsdl2pas_imp; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DOM, + parserdefs, cursor_intf, rtti_filters; + +type + + EWslParserException = class(Exception) + end; + + TWsdlParser = class; + + { TAbstractTypeParser } + + TAbstractTypeParser = class + private + FOwner : TWsdlParser; + FTypeNode : TDOMNode; + FSymbols : TSymbolTable; + FTypeName : string; + FEmbededDef : Boolean; + public + constructor Create( + AOwner : TWsdlParser; + ATypeNode : TDOMNode; + ASymbols : TSymbolTable; + const ATypeName : string; + const AEmbededDef : Boolean + ); + function Parse():TTypeDefinition;virtual;abstract; + end; + + TDerivationMode = ( dmNone, dmExtension, dmRestriction ); + TSequenceType = ( stElement, stAll ); + + { TComplexTypeParser } + + TComplexTypeParser = class(TAbstractTypeParser) + private + FAttCursor : IObjectCursor; + FChildCursor : IObjectCursor; + FContentNode : TDOMNode; + FContentType : string; + FBaseType : TTypeDefinition; + FDerivationMode : TDerivationMode; + FDerivationNode : TDOMNode; + FSequenceType : TSequenceType; + private + procedure CreateNodeCursors(); + procedure ExtractTypeName(); + procedure ExtractContentType(); + procedure ExtractBaseType(); + function ParseComplexContent(const ATypeName : string):TTypeDefinition; + function ParseSimpleContent(const ATypeName : string):TTypeDefinition; + function ParseEmptyContent(const ATypeName : string):TTypeDefinition; + public + function Parse():TTypeDefinition;override; + end; + + { TSimpleTypeParser } + + TSimpleTypeParser = class(TAbstractTypeParser) + private + FAttCursor : IObjectCursor; + FChildCursor : IObjectCursor; + FBaseName : string; + FRestrictionNode : TDOMNode; + FIsEnum : Boolean; + private + procedure CreateNodeCursors(); + procedure ExtractTypeName(); + procedure ExtractContentType(); + function ParseEnumContent():TTypeDefinition; + function ParseOtherContent():TTypeDefinition; + public + function Parse():TTypeDefinition;override; + end; + + { TWsdlParser } + + TWsdlParser = class + private + FDoc : TXMLDocument; + FSymbols : TSymbolTable; + private + FWsdlShortNames : TStringList; + FSoapShortNames : TStringList; + FXSShortNames : TStringList; + FServiceCursor : IObjectCursor; + FBindingCursor : IObjectCursor; + FPortTypeCursor : IObjectCursor; + FMessageCursor : IObjectCursor; + FTypesCursor : IObjectCursor; + FSchemaCursor : IObjectCursor; + private + procedure CreateWsdlNameFilter( + AFltrCreator : TRttiFilterCreator; + const AName : WideString + );overload; + procedure CreateXsNameFilter( + AFltrCreator : TRttiFilterCreator; + const AName : WideString + ); + + function CreateWsdlNameFilter(const AName : WideString):IObjectFilter; + function FindNamedNode(AList : IObjectCursor; const AName : WideString):TDOMNode; + procedure Prepare(); + procedure ParseService(ANode : TDOMNode); + procedure ParsePort(ANode : TDOMNode); + procedure ParsePortType( + ANode, ABindingNode : TDOMNode + ); + procedure ParseOperation( + AOwner : TInterfaceDefinition; + ANode : TDOMNode; + const ASoapBindingStyle : string + ); + function ParseType(const AName, ATypeOrElement : string) : TTypeDefinition; + public + constructor Create(ADoc : TXMLDocument; ASymbols : TSymbolTable); + destructor Destroy();override; + procedure Parse(); + property SymbolTable : TSymbolTable read FSymbols; + end; + + +implementation +uses dom_cursors, parserutils, StrUtils, Contnrs; + +const + s_all : WideString = 'all'; + s_any : WideString = 'any'; + s_array : WideString = 'array'; + s_arrayType : WideString = 'arrayType'; + s_attribute : WideString = 'attribute'; + s_base : WideString = 'base'; + s_binding : WideString = 'binding'; + s_complexContent : WideString = 'complexContent'; + s_complexType : WideString = 'complexType'; + s_document : WideString = 'document'; + s_element : WideString = 'element'; + s_enumeration : WideString = 'enumeration'; + s_extension : WideString = 'extension'; + s_input : WideString = 'input'; + s_item : WideString = 'item'; + s_message : WideString = 'message'; + s_maxOccurs : WideString = 'maxOccurs'; + s_minOccurs : WideString = 'minOccurs'; + s_name : WideString = 'name'; + s_operation : WideString = 'operation'; + s_optional : WideString = 'optional'; + s_output : WideString = 'output'; + s_part : WideString = 'part'; + s_port : WideString = 'port'; + s_portType : WideString = 'portType'; + s_prohibited : WideString = 'prohibited'; + s_required : WideString = 'required'; + s_restriction : WideString = 'restriction'; + s_return : WideString = 'return'; + s_rpc : WideString = 'rpc'; + s_schema : WideString = 'schema'; + s_xs : WideString = 'http://www.w3.org/2001/XMLSchema'; + s_sequence : WideString = 'sequence'; + s_service : WideString = 'service'; + s_simpleContent : WideString = 'simpleContent'; + s_simpleType : WideString = 'simpleType'; + s_soap : WideString = 'http://schemas.xmlsoap.org/wsdl/soap/'; + s_style : WideString = 'style'; + s_type : WideString = 'type'; + s_types : WideString = 'types'; + s_unbounded : WideString = 'unbounded'; + s_use : WideString = 'use'; + s_value : WideString = 'value'; + s_wsdl : WideString = 'http://schemas.xmlsoap.org/wsdl/'; + s_xmlns : WideString = 'xmlns'; + + //---------------------------------------------------------- + s_NODE_NAME = 'NodeName'; + s_NODE_VALUE = 'NodeValue'; + +type TCursorExposedType = ( cetRttiNode, cetDomNode ); +function CreateAttributesCursor(ANode : TDOMNode; const AExposedType : TCursorExposedType):IObjectCursor; +begin + Result := nil; + if ( ANode <> nil ) and ( ANode.Attributes <> nil ) then begin + Result := TDOMNamedNodeMapCursor.Create(ANode.Attributes,faNone) ; + if ( AExposedType = cetRttiNode ) then + Result := TDOMNodeRttiExposerCursor.Create(Result); + end; +end; + +function CreateChildrenCursor(ANode : TDOMNode; const AExposedType : TCursorExposedType):IObjectCursor; +begin + Result := nil; + if ( ANode <> nil ) and ANode.HasChildNodes() then begin + Result := TDOMNodeListCursor.Create(ANode.GetChildNodes(),faFreeOnDestroy) ; + if ( AExposedType = cetRttiNode ) then + Result := TDOMNodeRttiExposerCursor.Create(Result); + end; +end; + +function ExtractNameFromQName(const AQName : string):string ; +var + i : Integer; +begin + Result := Trim(AQName); + i := Pos(':',Result); + if ( i > 0 ) then + Result := Copy(Result,( i + 1 ), MaxInt); +end; + +procedure CreateQualifiedNameFilter( + AFltrCreator : TRttiFilterCreator; + const AName : WideString; + APrefixList : TStrings +); +var + k : Integer; + locStr : string; + locWStr : WideString; +begin + AFltrCreator.Clear(clrFreeObjects); + for k := 0 to Pred(APrefixList.Count) do begin + if IsStrEmpty(APrefixList[k]) then + locWStr := '' + else + locWStr := APrefixList[k] + ':'; + locWStr := locWStr + AName; + locStr := s_NODE_NAME; + AFltrCreator.AddCondition(locStr,sfoEqualCaseInsensitive,locWStr,fcOr); + end; +end; + +function CreateQualifiedNameFilterStr( + const AName : WideString; + APrefixList : TStrings +) : string; +var + k : Integer; + locStr : string; + locWStr : WideString; +begin + Result := ''; + for k := 0 to Pred(APrefixList.Count) do begin + if IsStrEmpty(APrefixList[k]) then + locWStr := '' + else + locWStr := APrefixList[k] + ':'; + locWStr := locWStr + AName; + locStr := s_NODE_NAME; + Result := Result + ' or ' + locStr + ' = ' + QuotedStr(locWStr); + end; + if ( Length(Result) > 0 ) then + Delete(Result,1,Length(' or')); +end; + +{ TWsdlParser } + +procedure TWsdlParser.CreateWsdlNameFilter(AFltrCreator : TRttiFilterCreator; const AName : WideString); +begin + CreateQualifiedNameFilter(AFltrCreator,AName,FWsdlShortNames); +end; + +procedure TWsdlParser.CreateXsNameFilter(AFltrCreator: TRttiFilterCreator;const AName: WideString); +begin + CreateQualifiedNameFilter(AFltrCreator,AName,FXSShortNames); +end; + +function TWsdlParser.CreateWsdlNameFilter(const AName: WideString): IObjectFilter; +var + k : Integer; + locStr : string; + locWStr : WideString; +begin + locStr := ''; + for k := 0 to Pred(FWsdlShortNames.Count) do begin + if IsStrEmpty(FWsdlShortNames[k]) then + locWStr := '' + else + locWStr := FWsdlShortNames[k] + ':'; + locWStr := locWStr + AName; + locStr := locStr + ' or ' + s_NODE_NAME + '=' + QuotedStr(locWStr) ; + end; + if ( Length(locStr) > 0 ) then + Delete(locStr,1,Length(' or ')); + Result := ParseFilter(locStr,TDOMNodeRttiExposer); +end; + +function TWsdlParser.FindNamedNode( + AList : IObjectCursor; + const AName : WideString +): TDOMNode; +var + attCrs, crs : IObjectCursor; + curObj : TDOMNodeRttiExposer; + fltrCreator : TRttiFilterCreator; + s : string; +begin + Result := nil; + fltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + s := s_NODE_NAME; + fltrCreator.AddCondition(s,sfoEqualCaseInsensitive,s_name,fcNone); + AList.Reset(); + while AList.MoveNext() do begin + curObj := AList.GetCurrent() as TDOMNodeRttiExposer; + attCrs := CreateAttributesCursor(curObj.InnerObject,cetRttiNode); + if Assigned(attCrs) then begin + crs := CreateCursorOn(attCrs,TRttiObjectFilter.Create(fltrCreator.Root,clrNone)); + crs.Reset(); + if crs.MoveNext() and WideSameText(AName,TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue) then begin + Result := curObj.InnerObject; + exit; + end; + end; + end; + finally + fltrCreator.Clear(clrFreeObjects); + FreeAndNil(fltrCreator); + end; +end; + +type + TNotFoundAction = ( nfaNone, nfaRaiseException ); +procedure ExtractNameSpaceShortNames( + AAttribCursor : IObjectCursor; + AResList : TStrings; + const ANameSpace : WideString; + const ANotFoundAction : TNotFoundAction; + const AClearBefore : Boolean +); +var + crs : IObjectCursor; + locObj : TDOMNodeRttiExposer; + wStr : WideString; + i : Integer; +begin + if AClearBefore then begin + AResList.Clear(); + end; + crs := CreateCursorOn(AAttribCursor,ParseFilter(Format('%s=%s',[s_NODE_VALUE,QuotedStr(ANameSpace)]),TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + repeat + locObj := crs.GetCurrent() as TDOMNodeRttiExposer; + wStr := Trim(locObj.NodeName); + i := AnsiPos(s_xmlns + ':',wStr); + if ( i > 0 ) then begin + i := AnsiPos(':',wStr); + AResList.Add(Copy(wStr,( i + 1 ), MaxInt)); + end else begin + if ( AResList.IndexOf('') = -1 ) then + AResList.Add(''); + end; + until not crs.MoveNext(); + end else begin + if ( ANotFoundAction = nfaRaiseException ) then begin + raise EWslParserException.CreateFmt('Namespace not found : "%s"',[ANameSpace]); + end; + end; +end; + +procedure ExtractNameSpaceShortNamesNested( + ANode : TDOMNode; + AResList : TStrings; + const ANameSpace : WideString +); +var + nd : TDOMNode; +begin + AResList.Clear(); + nd := ANode; + while Assigned(nd) do begin + if Assigned(nd.Attributes) and ( nd.Attributes.Length > 0 ) then begin + ExtractNameSpaceShortNames(CreateAttributesCursor(nd,cetRttiNode),AResList,ANameSpace,nfaNone,False); + end; + nd := nd.ParentNode; + end; +end; + +procedure TWsdlParser.Prepare(); +var + locAttCursor : IObjectCursor; + locChildCursor : IObjectCursor; + locFltrCreator : TRttiFilterCreator; + locObj : TDOMNodeRttiExposer; + locSrvcCrs : IObjectCursor; +begin + FPortTypeCursor := nil; + FWsdlShortNames.Clear(); + locAttCursor := CreateAttributesCursor(FDoc.DocumentElement,cetRttiNode); + + locChildCursor := TDOMNodeListCursor.Create(FDoc.DocumentElement.GetChildNodes,faFreeOnDestroy) ; + locChildCursor := TDOMNodeRttiExposerCursor.Create(locChildCursor); + + locFltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + ExtractNameSpaceShortNames(locAttCursor,FWsdlShortNames,s_wsdl,nfaRaiseException,True); + ExtractNameSpaceShortNames(locAttCursor,FSoapShortNames,s_soap,nfaRaiseException,False); + ExtractNameSpaceShortNames(locAttCursor,FXSShortNames,s_xs,nfaRaiseException,True); + + locFltrCreator.Clear(clrFreeObjects); + CreateWsdlNameFilter(locFltrCreator,s_service); + FServiceCursor := CreateCursorOn(locChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + FServiceCursor.Reset(); + + locFltrCreator.Clear(clrNone); + CreateWsdlNameFilter(locFltrCreator,s_binding); + FBindingCursor := CreateCursorOn(locChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + FBindingCursor.Reset(); + + locFltrCreator.Clear(clrNone); + CreateWsdlNameFilter(locFltrCreator,s_portType); + FPortTypeCursor := CreateCursorOn(locChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + FPortTypeCursor.Reset(); + + FSchemaCursor := nil; + locFltrCreator.Clear(clrNone); + CreateWsdlNameFilter(locFltrCreator,s_types); + FTypesCursor := CreateCursorOn(locChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + FTypesCursor.Reset(); + if FTypesCursor.MoveNext() then begin + locObj := FTypesCursor.GetCurrent() as TDOMNodeRttiExposer; + if locObj.InnerObject.HasChildNodes() then begin + FSchemaCursor := CreateChildrenCursor(locObj.InnerObject,cetRttiNode); + FSchemaCursor.Reset(); + locFltrCreator.Clear(clrNone); + CreateXsNameFilter(locFltrCreator,s_schema); + FSchemaCursor := CreateCursorOn( + FSchemaCursor,//.Clone() as IObjectCursor, + TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects) + ); + FSchemaCursor.Reset(); + end; + end; + + locFltrCreator.Clear(clrNone); + CreateWsdlNameFilter(locFltrCreator,s_message); + FMessageCursor := CreateCursorOn(locChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + FMessageCursor.Reset(); + + locSrvcCrs := FServiceCursor.Clone() as IObjectCursor; + while locSrvcCrs.MoveNext() do begin + locObj := locSrvcCrs.GetCurrent() as TDOMNodeRttiExposer; + ParseService(locObj.InnerObject); + end; + finally + locFltrCreator.Free(); + end; +end; + +procedure TWsdlParser.ParseService(ANode: TDOMNode); +var + locFltrCreator : TRttiFilterCreator; + locCursor, locPortCursor : IObjectCursor; + locObj : TDOMNodeRttiExposer; +begin + locFltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + CreateWsdlNameFilter(locFltrCreator,s_port); + locCursor := CreateChildrenCursor(ANode,cetRttiNode); + if Assigned(locCursor) then begin + locPortCursor := CreateCursorOn(locCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrFreeObjects)); + locFltrCreator.Clear(clrNone); + locPortCursor.Reset(); + while locPortCursor.MoveNext() do begin + locObj := locPortCursor.GetCurrent() as TDOMNodeRttiExposer; + ParsePort(locObj.InnerObject); + end; + end; + finally + locFltrCreator.Free(); + end; +end; + +procedure TWsdlParser.ParsePort(ANode: TDOMNode); + + function FindBindingNode(const AName : WideString):TDOMNode; + begin + Result := FindNamedNode(FBindingCursor,AName); + end; + + function ExtractBindingQName(out AName : WideString):Boolean ; + var + attCrs, crs : IObjectCursor; + fltrCreator : TRttiFilterCreator; + s : string; + begin + Result := False; + attCrs := CreateAttributesCursor(ANode,cetRttiNode); + if Assigned(attCrs) then begin + fltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + s := s_NODE_NAME; + fltrCreator.AddCondition(s,sfoEqualCaseInsensitive,s_binding,fcNone); + crs := CreateCursorOn(attCrs,TRttiObjectFilter.Create(fltrCreator.Root,clrNone)); + crs.Reset(); + if crs.MoveNext() then begin + AName := TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue; + Result := True; + exit; + end; + finally + fltrCreator.Clear(clrFreeObjects); + FreeAndNil(fltrCreator); + end; + end; + end; + + function ExtractTypeQName(ABndgNode : TDOMNode; out AName : WideString):Boolean ; + var + attCrs, crs : IObjectCursor; + fltrCreator : TRttiFilterCreator; + s : string; + begin + Result := False; + attCrs := CreateAttributesCursor(ABndgNode,cetRttiNode); + if Assigned(attCrs) then begin + fltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + s := s_NODE_NAME; + fltrCreator.AddCondition(s,sfoEqualCaseInsensitive,s_type,fcNone); + crs := CreateCursorOn(attCrs,TRttiObjectFilter.Create(fltrCreator.Root,clrNone)); + crs.Reset(); + if crs.MoveNext() then begin + AName := TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue; + Result := True; + exit; + end; + finally + fltrCreator.Clear(clrFreeObjects); + FreeAndNil(fltrCreator); + end; + end; + end; + + function FindTypeNode(const AName : WideString):TDOMNode; + begin + Result := FindNamedNode(FPortTypeCursor,AName); + end; + +var + bindingName, typeName : WideString; + i : Integer; + bindingNode, typeNode : TDOMNode; +begin + if ExtractBindingQName(bindingName) then begin + i := Pos(':',bindingName); + bindingName := Copy(bindingName,( i + 1 ), MaxInt); + bindingNode := FindBindingNode(bindingName); + if Assigned(bindingNode) then begin + if ExtractTypeQName(bindingNode,typeName) then begin + i := Pos(':',typeName); + typeName := Copy(typeName,( i + 1 ), MaxInt); + typeNode := FindTypeNode(typeName); + if Assigned(typeNode) then begin + ParsePortType(typeNode,bindingNode); + end; + end; + end; + end; +end; + +procedure TWsdlParser.ParsePortType(ANode, ABindingNode : TDOMNode); + + function ExtractSoapBindingStyle(out AName : WideString):Boolean ; + var + childrenCrs, crs, attCrs : IObjectCursor; + s : string; + begin + AName := ''; + Result := False; + childrenCrs := CreateChildrenCursor(ABindingNode,cetRttiNode); + if Assigned(childrenCrs) then begin + s := CreateQualifiedNameFilterStr(s_binding,FSoapShortNames); + crs := CreateCursorOn(childrenCrs,ParseFilter(s,TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + attCrs := CreateAttributesCursor(TDOMNodeRttiExposer(crs.GetCurrent()).InnerObject,cetRttiNode); + if Assigned(attCrs) then begin + s := s_NODE_NAME + ' = ' + QuotedStr(s_style); + crs := CreateCursorOn(attCrs,ParseFilter(s,TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + AName := TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue; + Result := True; + exit; + end; + end; + end; + end; + end; + +var + locIntf : TInterfaceDefinition; + locAttCursor : IObjectCursor; + locFltrCreator : TRttiFilterCreator; + locCursor, locOpCursor : IObjectCursor; + locObj : TDOMNodeRttiExposer; + i : Integer; + locStrBuffer, locSoapBindingStyle : string; + locWStrBuffer : WideString; +begin + locAttCursor := CreateAttributesCursor(ANode,cetRttiNode); + locFltrCreator := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + locStrBuffer := s_NODE_NAME; + locFltrCreator.AddCondition(locStrBuffer,sfoEqualCaseInsensitive,s_name,fcNone); + locCursor := CreateCursorOn(locAttCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrNone)); + locCursor.Reset(); + if not locCursor.MoveNext() then + raise EWslParserException.CreateFmt('PortType Attribute not found : "%s"',[s_name]); + locObj := locCursor.GetCurrent() as TDOMNodeRttiExposer; + locIntf := TInterfaceDefinition.Create(locObj.NodeValue); + try + FSymbols.Add(locIntf); + except + FreeAndNil(locIntf); + raise; + end; + locCursor := CreateChildrenCursor(ANode,cetRttiNode); + if Assigned(locCursor) then begin + locFltrCreator.Clear(clrFreeObjects); + for i := 0 to Pred(FWsdlShortNames.Count) do begin + if IsStrEmpty(FWsdlShortNames[i]) then + locWStrBuffer := '' + else + locWStrBuffer := FWsdlShortNames[i] + ':'; + locWStrBuffer := locWStrBuffer + s_operation; + locStrBuffer := s_NODE_NAME; + locFltrCreator.AddCondition(locStrBuffer,sfoEqualCaseInsensitive,locWStrBuffer,fcOr); + end; + locOpCursor := CreateCursorOn(locCursor,TRttiObjectFilter.Create(locFltrCreator.Root,clrNone)); + locOpCursor.Reset(); + ExtractSoapBindingStyle(locWStrBuffer); + locSoapBindingStyle := locWStrBuffer; + while locOpCursor.MoveNext() do begin + locObj := locOpCursor.GetCurrent() as TDOMNodeRttiExposer; + ParseOperation(locIntf,locObj.InnerObject,locSoapBindingStyle); + end; + end; + finally + locFltrCreator.Free(); + end; +end; + +type + + { TParamDefCrack } + + TParamDefCrack = class(TParameterDefinition) + public + procedure SetModifier(const AModifier : TParameterModifier); + end; + + { TMethodDefinitionCrack } + + TMethodDefinitionCrack = class(TMethodDefinition) + public + procedure SetMethodType( AMethodType : TMethodType ); + end; + +{ TMethodDefinitionCrack } + +procedure TMethodDefinitionCrack.SetMethodType(AMethodType: TMethodType); +begin + inherited; +end; + +{ TParamDefCrack } + +procedure TParamDefCrack.SetModifier(const AModifier: TParameterModifier); +begin + inherited; +end; + +procedure TWsdlParser.ParseOperation( + AOwner : TInterfaceDefinition; + ANode : TDOMNode; + const ASoapBindingStyle : string +); + + function ExtractOperationName(out AName : string):Boolean; + var + attCrs, crs : IObjectCursor; + begin + Result := False; + attCrs := CreateAttributesCursor(ANode,cetRttiNode); + if Assigned(attCrs) then begin + crs := CreateCursorOn(attCrs,ParseFilter(s_NODE_NAME + '=' + QuotedStr(s_name) ,TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + AName := TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue; + Result := True; + exit; + end; + end; + end; + + function ExtractMsgName(const AMsgType : string; out AName : string) : Boolean; + var + chldCrs, crs : IObjectCursor; + begin + chldCrs := CreateChildrenCursor(ANode,cetRttiNode); + if ( chldCrs <> nil ) then begin + //crs := CreateCursorOn(chldCrs,ParseFilter(s_NODE_NAME + '=' + QuotedStr(AMsgType) ,TDOMNodeRttiExposer)); + crs := CreateCursorOn(chldCrs,CreateWsdlNameFilter(AMsgType)); + crs.Reset(); + if crs.MoveNext() then begin + chldCrs := CreateAttributesCursor(TDOMNodeRttiExposer(crs.GetCurrent()).InnerObject,cetRttiNode); + if ( chldCrs <> nil ) then begin + crs := CreateCursorOn(chldCrs,ParseFilter(s_NODE_NAME + '=' + QuotedStr(s_message) ,TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + AName := TDOMNodeRttiExposer(crs.GetCurrent()).NodeValue; + Result := True; + exit; + end; + end; + end; + end; + Result := False; + end; + + function FindMessageNode(const AName : string) : TDOMNode; + begin + Result := FindNamedNode(FMessageCursor.Clone() as IObjectCursor,ExtractNameFromQName(AName)); + end; + + function CreatePartCursor(AMsgNode : TDOMNode):IObjectCursor ; + begin + Result := CreateChildrenCursor(AMsgNode,cetRttiNode); + if Assigned(Result) then + Result := CreateCursorOn(Result,CreateWsdlNameFilter(s_part)); + end; + + function GetDataType(const AName, ATypeOrElement : string):TTypeDefinition; + begin + try + Result := ParseType(AName,ATypeOrElement); + except + on e : Exception do begin + WriteLn(e.Message + ' ' + AName + ' ' + ATypeOrElement); + end; + end; + end; + + procedure ExtractMethod( + const AMthdName : string; + out AMthd : TMethodDefinition + ); + var + tmpMthd : TMethodDefinition; + + procedure ParseInputMessage(); + var + inMsg, strBuffer : string; + inMsgNode, tmpNode : TDOMNode; + crs, tmpCrs : IObjectCursor; + prmName, prmTypeName, prmTypeType : string; + prmInternameName : string; + prmHasInternameName : Boolean; + prmDef : TParameterDefinition; + begin + if ExtractMsgName(s_input,inMsg) then begin + inMsgNode := FindMessageNode(inMsg); + if ( inMsgNode <> nil ) then begin + crs := CreatePartCursor(inMsgNode); + if ( crs <> nil ) then begin + crs.Reset(); + While crs.MoveNext() do begin + tmpNode := (crs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if ( tmpNode.Attributes = nil ) or ( tmpNode.Attributes.Length < 1 ) then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + strBuffer := s_NODE_NAME + '=' + QuotedStr(s_name); + tmpCrs := CreateCursorOn( + CreateAttributesCursor(tmpNode,cetRttiNode), + ParseFilter(strBuffer,TDOMNodeRttiExposer) + ); + tmpCrs.Reset(); + if not tmpCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmName := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + strBuffer := s_NODE_NAME + '=' + QuotedStr(s_element) + ' or ' + s_NODE_NAME + ' = ' + QuotedStr(s_type); + tmpCrs := CreateCursorOn( + CreateAttributesCursor(tmpNode,cetRttiNode), + ParseFilter(strBuffer,TDOMNodeRttiExposer) + ); + tmpCrs.Reset(); + if not tmpCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmTypeName := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + prmTypeType := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeName; + if IsStrEmpty(prmName) or IsStrEmpty(prmTypeName) or IsStrEmpty(prmTypeType) then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmInternameName := Trim(prmName); + prmHasInternameName := IsReservedKeyWord(prmInternameName) or ( not IsValidIdent(prmInternameName) ); + if prmHasInternameName then + prmInternameName := '_' + prmInternameName; + prmDef := tmpMthd.AddParameter(prmInternameName,pmConst,GetDataType(prmTypeName,prmTypeType)); + if prmHasInternameName then begin + prmDef.RegisterExternalAlias(prmName); + end; + end; + end; + end; + end; + end; + + procedure ParseOutputMessage(); + var + outMsg, strBuffer : string; + outMsgNode, tmpNode : TDOMNode; + crs, tmpCrs : IObjectCursor; + prmName, prmTypeName, prmTypeType : string; + prmDef : TParameterDefinition; + prmInternameName : string; + prmHasInternameName : Boolean; + begin + if ExtractMsgName(s_output,outMsg) then begin + outMsgNode := FindMessageNode(outMsg); + if ( outMsgNode <> nil ) then begin + crs := CreatePartCursor(outMsgNode); + if ( crs <> nil ) then begin + prmDef := nil; + crs.Reset(); + While crs.MoveNext() do begin + tmpNode := (crs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if ( tmpNode.Attributes = nil ) or ( tmpNode.Attributes.Length < 1 ) then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + strBuffer := s_NODE_NAME + '=' + QuotedStr(s_name); + tmpCrs := CreateCursorOn(CreateAttributesCursor(tmpNode,cetRttiNode),ParseFilter(strBuffer,TDOMNodeRttiExposer)); + tmpCrs.Reset(); + if not tmpCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmName := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + strBuffer := s_NODE_NAME + '=' + QuotedStr(s_element) + ' or ' + s_NODE_NAME + ' = ' + QuotedStr(s_type); + tmpCrs := CreateCursorOn( + CreateAttributesCursor(tmpNode,cetRttiNode), + ParseFilter(strBuffer,TDOMNodeRttiExposer) + ); + tmpCrs.Reset(); + if not tmpCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmTypeName := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + prmTypeType := (tmpCrs.GetCurrent() as TDOMNodeRttiExposer).NodeName; + if IsStrEmpty(prmName) or IsStrEmpty(prmTypeName) or IsStrEmpty(prmTypeType) then + raise EWslParserException.CreateFmt('Invalid message part : "%s"',[tmpNode.NodeName]); + prmInternameName := Trim(prmName); + prmHasInternameName := IsReservedKeyWord(prmInternameName) or ( not IsValidIdent(prmInternameName) ); + if prmHasInternameName then + prmInternameName := '_' + prmInternameName; + prmDef := tmpMthd.FindParameter(prmName); + if ( prmDef = nil ) then begin + prmDef := tmpMthd.AddParameter(prmInternameName,pmOut,GetDataType(prmTypeName,prmTypeType)); + if prmHasInternameName then begin + prmDef.RegisterExternalAlias(prmName); + end; + end else begin + if prmDef.DataType.SameName(prmTypeName) then begin + TParamDefCrack(prmDef).SetModifier(pmVar); + end else begin + prmInternameName := '_' + prmInternameName; + prmDef := tmpMthd.AddParameter(prmInternameName,pmOut,GetDataType(prmTypeName,prmTypeType)); + prmDef.RegisterExternalAlias(prmName); + if prmHasInternameName then begin + prmDef.RegisterExternalAlias(prmName); + end; + end; + end; + end; + if ( SameText(ASoapBindingStyle,s_rpc) and + ( prmDef <> nil ) and SameText(prmDef.Name,s_return) and + ( prmDef = tmpMthd.Parameter[Pred(tmpMthd.ParameterCount)] ) + ) or + ( SameText(ASoapBindingStyle,s_document) and + ( prmDef <> nil ) and + ( prmDef.Modifier = pmOut ) and + ( prmDef = tmpMthd.Parameter[Pred(tmpMthd.ParameterCount)] ) + ) + then begin + TMethodDefinitionCrack(tmpMthd).SetMethodType(mtFunction); + end; + end; + end; + end; + end; + + begin + AMthd := nil; + tmpMthd := TMethodDefinition.Create(AMthdName,mtProcedure); + try + ParseInputMessage(); + ParseOutputMessage(); + except + FreeAndNil(tmpMthd); + AMthd := nil; + raise; + end; + AMthd := tmpMthd; + end; + +var + locMthd : TMethodDefinition; + mthdName : string; +begin + if not ExtractOperationName(mthdName) then + raise EWslParserException.CreateFmt('Operation Attribute not found : "%s"',[s_name]); + if SameText(s_document,ASoapBindingStyle) then begin + ExtractMethod(mthdName,locMthd); + if ( locMthd <> nil ) then + AOwner.AddMethod(locMthd); + end else if SameText(s_rpc,ASoapBindingStyle) then begin + ExtractMethod(mthdName,locMthd); + if ( locMthd <> nil ) then + AOwner.AddMethod(locMthd); + end; +end; + +function TWsdlParser.ParseType(const AName, ATypeOrElement: string): TTypeDefinition; +var + crsSchemaChild : IObjectCursor; + typNd : TDOMNode; + typName : string; + embededType : Boolean; + + procedure Init(); + var + nd : TDOMNodeRttiExposer; + schmCrsr : IObjectCursor; + begin + if not Assigned(FSchemaCursor) then + raise EWslParserException.Create('Schema cursor not assigned.'); + schmCrsr := FSchemaCursor.Clone() as IObjectCursor; + FSchemaCursor.Reset(); + if not FSchemaCursor.MoveNext() then + raise EWslParserException.Create('Schema cursor is empty.'); + nd := FSchemaCursor.GetCurrent() as TDOMNodeRttiExposer; + crsSchemaChild := CreateChildrenCursor(nd.InnerObject,cetRttiNode); + end; + + procedure FindTypeNode(); + var + nd : TDOMNode; + crs : IObjectCursor; + locStrFilter : string; + begin + typNd := FindNamedNode(crsSchemaChild,ExtractNameFromQName(AName)); + if not Assigned(typNd) then + raise EWslParserException.CreateFmt('Type definition not found 1 : "%s"',[AName]); + if AnsiSameText(ExtractNameFromQName(typNd.NodeName),s_element) then begin + crs := CreateCursorOn(CreateAttributesCursor(typNd,cetRttiNode),ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_type)]),TDOMNodeRttiExposer)); + crs.Reset(); + if crs.MoveNext() then begin + nd := (crs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + typNd := FindNamedNode(crsSchemaChild,ExtractNameFromQName(nd.NodeValue)); + if not Assigned(typNd) then + raise EWslParserException.CreateFmt('Type definition not found 2 : "%s"',[AName]); + embededType := False; + end else begin + //locStrFilter := Format('%s = %s or %s = %s ',[s_NODE_NAME,QuotedStr(s_complexType),s_NODE_NAME,QuotedStr(s_simpleType)]); + locStrFilter := CreateQualifiedNameFilterStr(s_complexType,FXSShortNames) + ' or ' + + CreateQualifiedNameFilterStr(s_simpleType,FXSShortNames); + crs := CreateCursorOn(CreateChildrenCursor(typNd,cetRttiNode),ParseFilter(locStrFilter,TDOMNodeRttiExposer)); + crs.Reset(); + if not crs.MoveNext() then begin + raise EWslParserException.CreateFmt('Type definition not found 3 : "%s"',[AName]); + end; + typNd := (crs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + typName := ExtractNameFromQName(AName); + embededType := True; + end; + end; + end; + + function ParseComplexType():TTypeDefinition; + var + locParser : TComplexTypeParser; + begin + locParser := TComplexTypeParser.Create(Self,typNd,FSymbols,typName,embededType); + try + Result := locParser.Parse(); + finally + FreeAndNil(locParser); + end; + end; + + function ParseSimpleType():TTypeDefinition; + var + locParser : TSimpleTypeParser; + begin + locParser := TSimpleTypeParser.Create(Self,typNd,FSymbols,typName,embededType); + try + Result := locParser.Parse(); + finally + FreeAndNil(locParser); + end; + end; + +begin + embededType := False; + Result := FSymbols.Find(ExtractNameFromQName(AName),TTypeDefinition) as TTypeDefinition; + if ( not Assigned(Result) )or ( Result is TForwardTypeDefinition ) then begin + Result := nil; + Init(); + FindTypeNode(); + if AnsiSameText(ExtractNameFromQName(typNd.NodeName),s_complexType) then begin + Result := ParseComplexType(); + end else if AnsiSameText(ExtractNameFromQName(typNd.NodeName),s_simpleType) then begin + Result := ParseSimpleType(); + end; + if Assigned(Result) then + FSymbols.Add(Result); + end; +end; + +constructor TWsdlParser.Create(ADoc: TXMLDocument; ASymbols : TSymbolTable); +begin + Assert(Assigned(ADoc)); + Assert(Assigned(ASymbols)); + FDoc := ADoc; + FWsdlShortNames := TStringList.Create(); + FSoapShortNames := TStringList.Create(); + FXSShortNames := TStringList.Create(); + FSymbols := ASymbols; + FSymbols.Add(CreateWstInterfaceSymbolTable()); +end; + +destructor TWsdlParser.Destroy(); +begin + FreeAndNil(FXSShortNames); + FreeAndNil(FSoapShortNames); + FreeAndNil(FWsdlShortNames); + inherited Destroy(); +end; + +procedure TWsdlParser.Parse(); + + procedure ParseForwardDeclarations(); + var + i, c : Integer; + sym : TAbstractSymbolDefinition; + typeCursor : IObjectCursor; + tmpNode : TDOMNode; + s : string; + begin + if Assigned(FSchemaCursor) then begin + FSchemaCursor.Reset(); + if FSchemaCursor.MoveNext() then begin + tmpNode := (FSchemaCursor.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if tmpNode.HasChildNodes() then begin + typeCursor := CreateChildrenCursor(tmpNode,cetRttiNode); + s := CreateQualifiedNameFilterStr(s_complexType,FXSShortNames) + ' or ' + + CreateQualifiedNameFilterStr(s_simpleType,FXSShortNames) + ' or ' + + CreateQualifiedNameFilterStr(s_element,FXSShortNames); + typeCursor := CreateCursorOn(typeCursor,ParseFilter(s,TDOMNodeRttiExposer)); + typeCursor.Reset(); + if typeCursor.MoveNext() then begin + c := FSymbols.Count; + i := 0; + while ( i < c ) do begin + sym := FSymbols[i]; + if ( sym is TForwardTypeDefinition ) then begin + typeCursor.Reset(); + tmpNode := FindNamedNode(typeCursor,sym.Name); + if Assigned(tmpNode) then begin + ParseType(sym.Name,ExtractNameFromQName(tmpNode.NodeName)); + Dec(i); + c := FSymbols.Count; + end else begin + WriteLn('XXXXXXXXXXXXXX = ',sym.Name); + end; + end; + Inc(i); + end; + end; + end; + end; + end; + end; + +begin + Prepare(); + ParseForwardDeclarations(); +end; + +{ TAbstractTypeParser } + +constructor TAbstractTypeParser.Create( + AOwner : TWsdlParser; + ATypeNode : TDOMNode; + ASymbols : TSymbolTable; + const ATypeName : string; + const AEmbededDef : Boolean +); +begin + Assert(Assigned(AOwner)); + Assert(Assigned(ATypeNode)); + Assert(Assigned(ASymbols)); + FOwner := AOwner; + FTypeNode := ATypeNode; + FSymbols := ASymbols; + FTypeName := ATypeName; + FEmbededDef := AEmbededDef; +end; + + +{ TComplexTypeParser } + +procedure TComplexTypeParser.CreateNodeCursors(); +begin + FAttCursor := CreateAttributesCursor(FTypeNode,cetRttiNode); + FChildCursor := CreateChildrenCursor(FTypeNode,cetRttiNode); +end; + +procedure TComplexTypeParser.ExtractTypeName(); +var + locCrs : IObjectCursor; +begin + if not FEmbededDef then begin + locCrs := CreateCursorOn( + FAttCursor.Clone() as IObjectCursor, + ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_name)]),TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if not locCrs.MoveNext() then + raise EWslParserException.Create('Unable to find the tag in the type node attributes.'); + FTypeName := (locCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + end; + if IsStrEmpty(FTypeName) then + raise EWslParserException.Create('Invalid type name( the name is empty ).'); +end; + +procedure TComplexTypeParser.ExtractContentType(); +var + locCrs : IObjectCursor; +begin + FContentType := ''; + if Assigned(FChildCursor) then begin + locCrs := CreateCursorOn( + FChildCursor.Clone() as IObjectCursor, + ParseFilter(CreateQualifiedNameFilterStr(s_complexContent,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + if Assigned(locCrs) then begin + locCrs.Reset(); + if locCrs.MoveNext() then begin + FContentNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + FContentType := FContentNode.NodeName; + end else begin + locCrs := CreateCursorOn( + FChildCursor.Clone() as IObjectCursor, + ParseFilter(CreateQualifiedNameFilterStr(s_simpleContent,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if locCrs.MoveNext() then begin + FContentNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + FContentType := FContentNode.NodeName; + end else begin + FContentNode := FTypeNode; + FContentType := s_complexContent; + end; + end; + FContentType := ExtractNameFromQName(FContentType); + end; + end; +end; + +procedure TComplexTypeParser.ExtractBaseType(); +var + locContentChildCrs, locCrs : IObjectCursor; + locSymbol : TAbstractSymbolDefinition; + locBaseTypeName, locFilterStr : string; +begin + locFilterStr := CreateQualifiedNameFilterStr(s_extension,FOwner.FXSShortNames); + locContentChildCrs := CreateChildrenCursor(FContentNode,cetRttiNode); + locCrs := CreateCursorOn( + locContentChildCrs.Clone() as IObjectCursor, + ParseFilter(locFilterStr,TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if locCrs.MoveNext() then begin + FDerivationMode := dmExtension; + FDerivationNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + end else begin + locFilterStr := CreateQualifiedNameFilterStr(s_restriction,FOwner.FXSShortNames); + locCrs := CreateCursorOn( + locContentChildCrs.Clone() as IObjectCursor, + ParseFilter(locFilterStr,TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if locCrs.MoveNext() then begin + FDerivationMode := dmRestriction; + FDerivationNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + end else begin + FDerivationMode := dmNone; + FDerivationNode := nil; + end; + end; + if ( FDerivationMode > dmNone ) then begin + locCrs := CreateCursorOn( + CreateAttributesCursor(FDerivationNode,cetRttiNode), + ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_base)]),TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if not locCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid extention/restriction of type "%s" : "base" attribute not found.',[FTypeName]); + locBaseTypeName := ExtractNameFromQName((locCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue); + locSymbol := FSymbols.Find(locBaseTypeName);//,TClassTypeDefinition); + if Assigned(locSymbol) then begin + if locSymbol.InheritsFrom(TTypeDefinition) then begin + FBaseType := locSymbol as TTypeDefinition; + if FBaseType.InheritsFrom(TNativeSimpleTypeDefinition) then begin + Assert(Assigned(TNativeSimpleTypeDefinition(FBaseType).BoxedType)); + FBaseType := TNativeSimpleTypeDefinition(FBaseType).BoxedType; + end; + end else begin + raise EWslParserException.CreateFmt('"%s" was expected to be a type definition.',[locSymbol.Name]); + end; + end else begin + FBaseType := TForwardTypeDefinition.Create(locBaseTypeName); + FSymbols.Add(FBaseType); + end; + end; +end; + +function TComplexTypeParser.ParseComplexContent(const ATypeName : string) : TTypeDefinition; + + function ExtractElementCursor():IObjectCursor; + var + frstCrsr, tmpCursor : IObjectCursor; + parentNode, tmpNode : TDOMNode; + begin + Result := nil; + case FDerivationMode of + dmNone : parentNode := FContentNode; + dmRestriction, + dmExtension : parentNode := FDerivationNode; + end; + if parentNode.HasChildNodes() then begin; + frstCrsr := CreateChildrenCursor(parentNode,cetRttiNode); + tmpCursor := CreateCursorOn( + frstCrsr.Clone() as IObjectCursor, + ParseFilter(CreateQualifiedNameFilterStr(s_sequence,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + tmpCursor.Reset(); + if tmpCursor.MoveNext() then begin + FSequenceType := stElement; + tmpNode := (tmpCursor.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if tmpNode.HasChildNodes() then begin + tmpCursor := CreateCursorOn( + CreateChildrenCursor(tmpNode,cetRttiNode), + ParseFilter(CreateQualifiedNameFilterStr(s_element,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + Result := tmpCursor; + end; + end else begin + tmpCursor := CreateCursorOn( + frstCrsr.Clone() as IObjectCursor, + ParseFilter(CreateQualifiedNameFilterStr(s_all,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + tmpCursor.Reset(); + if tmpCursor.MoveNext() then begin + FSequenceType := stElement; + tmpNode := (tmpCursor.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if tmpNode.HasChildNodes() then begin + tmpCursor := CreateCursorOn( + CreateChildrenCursor(tmpNode,cetRttiNode), + ParseFilter(CreateQualifiedNameFilterStr(s_element,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + Result := tmpCursor; + end; + end; + end + end else begin + Result := nil; + end; + end; + +var + classDef : TClassTypeDefinition; + isArrayDef : Boolean; + arrayItems : TObjectList; + + procedure ParseElement(AElement : TDOMNode); + var + locAttCursor, locPartCursor : IObjectCursor; + locName, locTypeName : string; + locType : TAbstractSymbolDefinition; + locInternalEltName : string; + locProp : TPropertyDefinition; + locHasInternalName : Boolean; + locMinOccur, locMaxOccur : Integer; + locMaxOccurUnbounded : Boolean; + locStrBuffer : string; + begin + locAttCursor := CreateAttributesCursor(AElement,cetRttiNode); + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_name)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if not locPartCursor.MoveNext() then + raise EWslParserException.Create('Invalid definition : missing "name" attribute.'); + locName := (locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + if IsStrEmpty(locName) then + raise EWslParserException.Create('Invalid definition : empty "name".'); + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_type)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if not locPartCursor.MoveNext() then + raise EWslParserException.Create('Invalid definition : missing "type" attribute.'); + locTypeName := ExtractNameFromQName((locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue); + if IsStrEmpty(locTypeName) then + raise EWslParserException.Create('Invalid definition : empty "type".'); + locType := FSymbols.Find(locTypeName); + if not Assigned(locType) then begin + locType := TForwardTypeDefinition.Create(locTypeName); + FSymbols.Add(locType); + end; + + locInternalEltName := locName; + locHasInternalName := IsReservedKeyWord(locInternalEltName); + if locHasInternalName then + locInternalEltName := Format('_%s',[locInternalEltName]); + + locProp := classDef.AddProperty(locInternalEltName,locType as TTypeDefinition); + if locHasInternalName then + locProp.RegisterExternalAlias(locName); + + locMinOccur := 1; + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_minOccurs)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if locPartCursor.MoveNext() then begin + if not TryStrToInt((locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue,locMinOccur) then + raise EWslParserException.CreateFmt('Invalid "minOccurs" value : "%s.%s".',[FTypeName,locName]); + if ( locMinOccur < 0 ) then + raise EWslParserException.CreateFmt('Invalid "minOccurs" value : "%s.%s".',[FTypeName,locName]); + end; + if ( locMinOccur = 0 ) then + locProp.StorageOption := soOptional; + + locMaxOccur := 1; + locMaxOccurUnbounded := False; + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_maxOccurs)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if locPartCursor.MoveNext() then begin + locStrBuffer := (locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + if AnsiSameText(locStrBuffer,s_unbounded) then begin + locMaxOccurUnbounded := True; + end else begin + if not TryStrToInt(locStrBuffer,locMaxOccur) then + raise EWslParserException.CreateFmt('Invalid "maxOccurs" value : "%s.%s".',[FTypeName,locName]); + if ( locMinOccur < 0 ) then + raise EWslParserException.CreateFmt('Invalid "maxOccurs" value : "%s.%s".',[FTypeName,locName]); + end; + end; + isArrayDef := locMaxOccurUnbounded or ( locMaxOccur > 1 ); + if isArrayDef then begin + arrayItems.Add(locProp); + end; + end; + + procedure GenerateArrayTypes( + const AClassName : string; + AArrayPropList : TObjectList + ); + var + locPropTyp : TPropertyDefinition; + k : Integer; + begin + for k := 0 to Pred(AArrayPropList.Count) do begin + locPropTyp := AArrayPropList[k] as TPropertyDefinition; + FSymbols.Add( + TArrayDefinition.Create( + Format('%s_%sArray',[AClassName,locPropTyp.Name]), + locPropTyp.DataType, + locPropTyp.Name + ) + ); + end; + end; + + function ExtractSoapArray(const AInternalName : string; const AHasInternalName : Boolean) : TArrayDefinition; + var + ls : TStringList; + crs, locCrs : IObjectCursor; + s : string; + i : Integer; + locSym : TAbstractSymbolDefinition; + ok : Boolean; + nd : TDOMNode; + begin + if not FDerivationNode.HasChildNodes then begin + raise EWslParserException.CreateFmt('Invalid type definition, attributes not found : "%s".',[FTypeName]); + end; + crs := CreateCursorOn( + CreateChildrenCursor(FDerivationNode,cetRttiNode), + ParseFilter(CreateQualifiedNameFilterStr(s_attribute,FOwner.FXSShortNames),TDOMNodeRttiExposer) + ); + ls := TStringList.Create(); + try + ok := False; + crs.Reset(); + while crs.MoveNext() do begin + nd := (crs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if Assigned(nd.Attributes) and ( nd.Attributes.Length > 0 ) then begin + ls.Clear(); + ExtractNameSpaceShortNamesNested(nd,ls,s_wsdl); + locCrs := CreateAttributesCursor(nd,cetRttiNode); + locCrs := CreateCursorOn( + locCrs, + ParseFilter(CreateQualifiedNameFilterStr(s_arrayType,ls),TDOMNodeRttiExposer) + ); + if Assigned(locCrs) then begin + locCrs.Reset(); + if locCrs.MoveNext() then begin + ok := True; + Break; + end; + end; + end; + end; + finally + FreeAndNil(ls); + end; + if not ok then begin + raise EWslParserException.CreateFmt('Invalid type definition, unable to find the "%s" attribute : "%s".',[s_arrayType,FTypeName]); + end; + s := ExtractNameFromQName((locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject.NodeValue); + i := Pos('[',s); + if ( i < 1 ) then begin + i := MaxInt; + end; + s := Copy(s,1,Pred(i)); + locSym := FSymbols.Find(s); + if not Assigned(locSym) then begin + locSym := TForwardTypeDefinition.Create(s); + FSymbols.Add(locSym); + end; + if not locSym.InheritsFrom(TTypeDefinition) then + raise EWslParserException.CreateFmt('Invalid array type definition, invalid item type definition : "%s".',[FTypeName]); + Result := TArrayDefinition.Create(AInternalName,locSym as TTypeDefinition,s_item); + if AHasInternalName then + Result.RegisterExternalAlias(ATypeName); + end; + +var + eltCrs : IObjectCursor; + internalName : string; + hasInternalName : Boolean; + arrayDef : TArrayDefinition; + propTyp : TPropertyDefinition; + tmpClassDef : TClassTypeDefinition; + i : Integer; +begin + ExtractBaseType(); + eltCrs := ExtractElementCursor(); + + internalName := ATypeName; + hasInternalName := IsReservedKeyWord(internalName) or + ( not IsValidIdent(internalName) );{ or + ( FSymbols.IndexOf(internalName) <> -1 );} + if hasInternalName then + internalName := Format('_%s',[internalName]); + + if ( FDerivationMode = dmRestriction ) and FBaseType.SameName(s_array) then begin + Result := ExtractSoapArray(internalName,hasInternalName); + end else begin + arrayItems := TObjectList.Create(False); + try + classDef := TClassTypeDefinition.Create(internalName); + try + Result := classDef; + if hasInternalName then + classDef.RegisterExternalAlias(ATypeName); + if ( FDerivationMode in [dmExtension, dmRestriction] ) then begin + classDef.SetParent(FBaseType); + end; + if ( classDef.Parent = nil ) then + classDef.SetParent( + (FSymbols.ByName('base_service_intf') as TSymbolTable) + .ByName('TBaseComplexRemotable') as TClassTypeDefinition + ); + if Assigned(eltCrs) then begin + isArrayDef := False; + eltCrs.Reset(); + while eltCrs.MoveNext() do begin + ParseElement((eltCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject); + end; + if ( arrayItems.Count > 0 ) then begin + if ( arrayItems.Count = 1 ) and ( classDef.PropertyCount = 1 ) then begin + Result := nil; + propTyp := arrayItems[0] as TPropertyDefinition; + //arrayDef := TArrayDefinition.Create(internalName,(arrayItemType as TTypeDefinition),arrayItemName); + arrayDef := TArrayDefinition.Create(internalName,propTyp.DataType,propTyp.Name); + FreeAndNil(classDef); + Result := arrayDef; + if hasInternalName then + arrayDef.RegisterExternalAlias(ATypeName); + end else begin + GenerateArrayTypes(internalName,arrayItems); + tmpClassDef := classDef; + classDef := TClassTypeDefinition.Create(tmpClassDef.Name); + Result := classDef; + classDef.SetParent(tmpClassDef.Parent); + if hasInternalName then + classDef.RegisterExternalAlias(ATypeName); + for i := 0 to Pred(tmpClassDef.PropertyCount) do begin + propTyp := tmpClassDef.Properties[i]; + if ( arrayItems.IndexOf(propTyp) = -1 ) then begin + classDef.AddProperty(propTyp.Name,propTyp.DataType); + end else begin + classDef.AddProperty( + propTyp.Name, + FSymbols.ByName(Format('%s_%sArray',[internalName,propTyp.Name])) as TTypeDefinition + ); + end; + end; + FreeAndNil(tmpClassDef); + end; + end; + end; + except + FreeAndNil(Result); + raise; + end; + finally + FreeAndNil(arrayItems); + end; + end; +end; + +function TComplexTypeParser.ParseSimpleContent(const ATypeName : string) : TTypeDefinition; + + function ExtractAttributeCursor():IObjectCursor; + var + frstCrsr, tmpCursor : IObjectCursor; + parentNode, tmpNode : TDOMNode; + locFilterStr : string; + begin + Result := nil; + parentNode := FContentNode; + if parentNode.HasChildNodes() then begin; + frstCrsr := CreateChildrenCursor(parentNode,cetRttiNode); + locFilterStr := CreateQualifiedNameFilterStr(s_extension,FOwner.FXSShortNames) + ' or ' + + CreateQualifiedNameFilterStr(s_restriction,FOwner.FXSShortNames) ; + tmpCursor := CreateCursorOn(frstCrsr.Clone() as IObjectCursor,ParseFilter(locFilterStr,TDOMNodeRttiExposer)); + if Assigned(tmpCursor) then begin + tmpCursor.Reset(); + if tmpCursor.MoveNext() then begin + tmpNode := (tmpCursor.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + if tmpNode.HasChildNodes() then begin + locFilterStr := CreateQualifiedNameFilterStr(s_attribute,FOwner.FXSShortNames); + tmpCursor := CreateCursorOn(CreateChildrenCursor(tmpNode,cetRttiNode),ParseFilter(locFilterStr,TDOMNodeRttiExposer)); + if Assigned(tmpCursor) then begin + Result := tmpCursor; + Result.Reset(); + end; + end; + end; + end; + end else begin + Result := nil; + end; + end; + +var + locClassDef : TClassTypeDefinition; + + procedure ParseAttribute(AElement : TDOMNode); + var + locAttCursor, locPartCursor : IObjectCursor; + locName, locTypeName, locStoreOpt : string; + locType : TAbstractSymbolDefinition; + locStoreOptIdx : Integer; + locAttObj : TPropertyDefinition; + locInternalEltName : string; + locHasInternalName : boolean; + begin + locAttCursor := CreateAttributesCursor(AElement,cetRttiNode); + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_name)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if not locPartCursor.MoveNext() then + raise EWslParserException.CreateFmt('Invalid <%s> definition : missing "name" attribute.',[s_attribute]); + locName := (locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + if IsStrEmpty(locName) then + raise EWslParserException.CreateFmt('Invalid <%s> definition : empty "name".',[s_attribute]); + + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_type)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if not locPartCursor.MoveNext() then + raise EWslParserException.CreateFmt('Invalid <%s> definition : missing "type" attribute.',[s_attribute]); + locTypeName := ExtractNameFromQName((locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue); + if IsStrEmpty(locTypeName) then + raise EWslParserException.CreateFmt('Invalid <%s> definition : empty "type".',[s_attribute]); + locType := FSymbols.Find(locTypeName); + if not Assigned(locType) then begin + locType := TForwardTypeDefinition.Create(locTypeName); + FSymbols.Add(locType); + end; + + locPartCursor := CreateCursorOn(locAttCursor.Clone() as IObjectCursor,ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_use)]),TDOMNodeRttiExposer)); + locPartCursor.Reset(); + if locPartCursor.MoveNext() then begin + locStoreOpt := ExtractNameFromQName((locPartCursor.GetCurrent() as TDOMNodeRttiExposer).NodeValue); + if IsStrEmpty(locStoreOpt) then + raise EWslParserException.CreateFmt('Invalid <%s> definition : empty "use".',[s_attribute]); + locStoreOptIdx := AnsiIndexText(locStoreOpt,[s_required,s_optional,s_prohibited]); + if ( locStoreOptIdx < Ord(Low(TStorageOption)) ) or ( locStoreOptIdx > Ord(High(TStorageOption)) ) then + raise EWslParserException.CreateFmt('Invalid <%s> definition : invalid "use" value "%s".',[s_attribute,locStoreOpt]); + end else begin + locStoreOptIdx := 0; + end; + + locInternalEltName := locName; + locHasInternalName := IsReservedKeyWord(locInternalEltName); + if locHasInternalName then + locInternalEltName := Format('_%s',[locInternalEltName]); + + locAttObj := locClassDef.AddProperty(locInternalEltName,locType as TTypeDefinition); + if locHasInternalName then + locAttObj.RegisterExternalAlias(locName); + locAttObj.IsAttribute := True; + locAttObj.StorageOption := TStorageOption(locStoreOptIdx); + end; + +var + locAttCrs : IObjectCursor; + internalName : string; + hasInternalName : Boolean; +begin + ExtractBaseType(); + if not ( FDerivationMode in [dmExtension, dmRestriction] ) then + raise EWslParserException.Create('Invalid "complexeType.simpleType" definition : restriction/extension not found.'); + + internalName := ATypeName; + hasInternalName := IsReservedKeyWord(internalName) or + ( not IsValidIdent(internalName) );{ or + ( FSymbols.IndexOf(internalName) <> -1 );} + if hasInternalName then + internalName := Format('_%s',[internalName]); + + locAttCrs := ExtractAttributeCursor(); + locClassDef := TClassTypeDefinition.Create(Trim(internalName)); + try + Result := locClassDef; + if hasInternalName then + locClassDef.RegisterExternalAlias(ATypeName); + if ( FDerivationMode in [dmExtension, dmRestriction] ) then begin + locClassDef.SetParent(FBaseType); + end; + if ( locClassDef.Parent = nil ) then begin + locClassDef.SetParent( + (FSymbols.ByName('base_service_intf') as TSymbolTable) + .ByName('TBaseComplexRemotable') as TClassTypeDefinition + ); + end; + if ( locAttCrs <> nil ) then begin + locAttCrs.Reset(); + while locAttCrs.MoveNext() do begin + ParseAttribute((locAttCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject); + end; + end; + except + FreeAndNil(Result); + raise; + end; +end; + +function TComplexTypeParser.ParseEmptyContent(const ATypeName: string): TTypeDefinition; +var + internalName : string; + hasInternalName : Boolean; +begin + internalName := ATypeName; + hasInternalName := IsReservedKeyWord(internalName) or + ( not IsValidIdent(internalName) );{ or + ( FSymbols.IndexOf(internalName) <> -1 );} + if hasInternalName then + internalName := Format('_%s',[internalName]); + Result := TClassTypeDefinition.Create(internalName); + if hasInternalName then + Result.RegisterExternalAlias(ATypeName); + TClassTypeDefinition(Result).SetParent( + (FSymbols.ByName('base_service_intf') as TSymbolTable) + .ByName('TBaseComplexRemotable') as TClassTypeDefinition + ); +end; + +function TComplexTypeParser.Parse() : TTypeDefinition; +var + locSym : TAbstractSymbolDefinition; + locContinue : Boolean; +begin + if not AnsiSameText(ExtractNameFromQName(FTypeNode.NodeName),s_complexType) then + raise EWslParserException.CreateFmt('%s expected but %s found.',[s_complexType,ExtractNameFromQName(FTypeNode.NodeName)]); + CreateNodeCursors(); + ExtractTypeName(); + locContinue := True; + locSym := FSymbols.Find(FTypeName); + if Assigned(locSym) then begin + if not locSym.InheritsFrom(TTypeDefinition) then + raise EWslParserException.CreateFmt('Symbol found in the symbol table but is not a type definition : %s.',[FTypeName]); + locContinue := locSym.InheritsFrom(TForwardTypeDefinition); + if not locContinue then; + Result := locSym as TTypeDefinition; + end; + if locContinue then begin + ExtractContentType(); + if IsStrEmpty(FContentType) then begin + Result := ParseEmptyContent(FTypeName); + end else begin + if AnsiSameText(FContentType,s_complexContent) then + Result := ParseComplexContent(FTypeName) + else + Result := ParseSimpleContent(FTypeName); + end; + end; +end; + +{ TSimpleTypeParser } + +procedure TSimpleTypeParser.CreateNodeCursors(); +begin + FAttCursor := CreateAttributesCursor(FTypeNode,cetRttiNode); + FChildCursor := CreateChildrenCursor(FTypeNode,cetRttiNode); +end; + +procedure TSimpleTypeParser.ExtractTypeName(); +var + locCrs : IObjectCursor; +begin + if not FEmbededDef then begin + locCrs := CreateCursorOn( + FAttCursor.Clone() as IObjectCursor, + ParseFilter(Format('%s = %s',[s_NODE_NAME,QuotedStr(s_name)]),TDOMNodeRttiExposer) + ); + locCrs.Reset(); + if not locCrs.MoveNext() then + raise EWslParserException.Create('Unable to find the tag in the type node attributes.'); + FTypeName := (locCrs.GetCurrent() as TDOMNodeRttiExposer).NodeValue; + end; + if IsStrEmpty(FTypeName) then + raise EWslParserException.Create('Invalid type name( the name is empty ).'); +end; + +procedure TSimpleTypeParser.ExtractContentType(); +var + locCrs, locAttCrs : IObjectCursor; + fltrCtr : TRttiFilterCreator; + tmpNode : TDOMNode; +begin + fltrCtr := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + CreateQualifiedNameFilter(fltrCtr,s_restriction,FOwner.FXSShortNames); + locCrs := CreateCursorOn( + FChildCursor.Clone() as IObjectCursor,TRttiObjectFilter.Create(fltrCtr.Root,clrFreeObjects) + ); + locCrs.Reset(); + if locCrs.MoveNext() then begin + FRestrictionNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + tmpNode := nil; + locAttCrs := CreateAttributesCursor(FRestrictionNode,cetRttiNode); + if Assigned(locAttCrs) then begin + locAttCrs := CreateCursorOn(locAttCrs,ParseFilter(Format('%s=%s',[s_NODE_NAME,QuotedStr(s_base)]),TDOMNodeRttiExposer)); + locAttCrs.Reset(); + if locAttCrs.MoveNext() then begin + tmpNode := (locAttCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + end; + end; + FBaseName := ''; + if Assigned(tmpNode) then begin + FBaseName := ExtractNameFromQName(tmpNode.NodeValue); + end; + fltrCtr.Clear(clrNone); + CreateQualifiedNameFilter(fltrCtr,s_enumeration,FOwner.FXSShortNames); + locCrs := CreateChildrenCursor(FRestrictionNode,cetRttiNode) as IObjectCursor; + if Assigned(locCrs) then begin + locCrs.Reset(); + if locCrs.MoveNext() then begin + FIsEnum := True; + end else begin + if IsStrEmpty(FBaseName) then + raise EWslParserException.CreateFmt('Base type is not specified for the simple type, parsing : "%s".',[FTypeName]); + FIsEnum := False + end; + end else begin + if IsStrEmpty(FBaseName) then + raise EWslParserException.CreateFmt('Base type is not specified for the simple type, parsing : "%s".',[FTypeName]); + FIsEnum := False + end; + end else begin + raise EWslParserException.CreateFmt('The parser only support "Restriction" mode simple type derivation, parsing : "%s".',[FTypeName]); + end; + finally + fltrCtr.Clear(clrNone); + FreeAndNil(fltrCtr); + end; +end; + +function TSimpleTypeParser.ParseEnumContent(): TTypeDefinition; + + function ExtractEnumCursor():IObjectCursor ; + var + fltrCtr : TRttiFilterCreator; + begin + fltrCtr := TRttiFilterCreator.Create(TDOMNodeRttiExposer); + try + CreateQualifiedNameFilter(fltrCtr,s_enumeration,FOwner.FXSShortNames); + Result := CreateCursorOn( + CreateChildrenCursor(FRestrictionNode,cetRttiNode), + TRttiObjectFilter.Create(fltrCtr.Root,clrFreeObjects) + ); + finally + fltrCtr.Clear(clrNone); + FreeAndNil(fltrCtr); + end; + end; + +var + locRes : TEnumTypeDefinition; + locOrder : Integer; + + procedure ParseEnumItem(AItemNode : TDOMNode); + var + tmpNode : TDOMNode; + locItemName, locInternalItemName : string; + locCrs : IObjectCursor; + locItem : TEnumItemDefinition; + locHasInternalName : Boolean; + begin + locCrs := CreateCursorOn(CreateAttributesCursor(AItemNode,cetRttiNode),ParseFilter(Format('%s=%s',[s_NODE_NAME,QuotedStr(s_value)]),TDOMNodeRttiExposer)) as IObjectCursor; + if not Assigned(locCrs) then + raise EWslParserException.CreateFmt('Invalid "enum" item node : no value attribute, type = "%s".',[FTypeName]); + locCrs.Reset(); + if not locCrs.MoveNext() then + raise EWslParserException.CreateFmt('Invalid "enum" item node : no value attribute, type = "%s".',[FTypeName]); + tmpNode := (locCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject; + locItemName := tmpNode.NodeValue; + if IsStrEmpty(locItemName) then + raise EWslParserException.CreateFmt('Invalid "enum" item node : the value attribute is empty, type = "%s".',[FTypeName]); + + locInternalItemName := locItemName; + locHasInternalName := IsReservedKeyWord(locInternalItemName) or + ( not IsValidIdent(locInternalItemName) ) or + ( FSymbols.IndexOf(locInternalItemName) <> -1 ); + if locHasInternalName then + locInternalItemName := Format('%s_%s',[locRes.ExternalName,locInternalItemName]); + locItem := TEnumItemDefinition.Create(locInternalItemName,locRes,locOrder); + if locHasInternalName then + locItem.RegisterExternalAlias(locItemName); + FSymbols.Add(locItem); + locRes.AddItem(locItem); + Inc(locOrder); + end; + +var + locEnumCrs : IObjectCursor; + intrName : string; + hasIntrnName : Boolean; +begin + locEnumCrs := ExtractEnumCursor(); + + intrName := FTypeName; + hasIntrnName := IsReservedKeyWord(FTypeName) or + ( FSymbols.IndexOf(intrName) < 0 ); + if hasIntrnName then + intrName := '_' + intrName; + + locRes := TEnumTypeDefinition.Create(Trim(intrName)); + try + Result := locRes; + if hasIntrnName then + locRes.RegisterExternalAlias(FTypeName); + locEnumCrs.Reset(); + locOrder := 0; + while locEnumCrs.MoveNext() do begin + ParseEnumItem((locEnumCrs.GetCurrent() as TDOMNodeRttiExposer).InnerObject); + end; + except + FreeAndNil(Result); + raise; + end; +end; + +function TSimpleTypeParser.ParseOtherContent(): TTypeDefinition; +begin // todo : implement TSimpleTypeParser.ParseOtherContent + if IsStrEmpty(FBaseName) then + raise EWslParserException.CreateFmt('Invalid simple type definition : base type not provided, "%s".',[FTypeName]); + Result := TTypeAliasDefinition.Create(FTypeName,FSymbols.ByName(FBaseName) as TTypeDefinition); +end; + +function TSimpleTypeParser.Parse(): TTypeDefinition; +var + locSym : TAbstractSymbolDefinition; + locContinue : Boolean; +begin + if not AnsiSameText(ExtractNameFromQName(FTypeNode.NodeName),s_simpleType) then + raise EWslParserException.CreateFmt('%s expected but %s found.',[s_simpleType,ExtractNameFromQName(FTypeNode.NodeName)]); + CreateNodeCursors(); + ExtractTypeName(); + locContinue := True; + locSym := FSymbols.Find(FTypeName); + if Assigned(locSym) then begin + if not locSym.InheritsFrom(TTypeDefinition) then + raise EWslParserException.CreateFmt('Symbol found in the symbol table but is not a type definition : %s.',[FTypeName]); + locContinue := locSym.InheritsFrom(TForwardTypeDefinition); + if not locContinue then begin + Result := locSym as TTypeDefinition; + end; + end; + if locContinue then begin + ExtractContentType(); + if FIsEnum then begin + Result := ParseEnumContent() + end else begin + Result := ParseOtherContent(); + end; + end; +end; + +end. + diff --git a/wst/trunk/wst_rtti_filter/cursor_intf.pas b/wst/trunk/wst_rtti_filter/cursor_intf.pas new file mode 100644 index 000000000..51e9240d7 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/cursor_intf.pas @@ -0,0 +1,153 @@ +unit cursor_intf; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +type + + ECursorException = class(Exception) + end; + + ICursor = interface + ['{2B7756B1-E239-4B6F-A7A3-4B57B98FAD4F}'] + procedure Reset(); + function MoveNext() : Boolean; + function Clone():ICursor; + end; + + IObjectFilter = interface + ['{3DFB1A26-ED2D-428A-9F62-2091A076D97B}'] + function Evaluate(const AObject : TObject) : Boolean; + end; + + IObjectCursor = interface(ICursor) + ['{13E9C22D-0508-4D7A-A969-96E2291B4FE8}'] + function GetCurrent() : TObject; + end; + + IFilterableObjectCursor = interface(IObjectCursor) + ['{F11B588A-E8CF-45D3-98D2-B49755FFC22D}'] + function GetFilter() : IObjectFilter; + function SetFilter(const AFilter : IObjectFilter) : IObjectFilter; + end; + + function CreateCursorOn( + AInputCursor : IObjectCursor; + AFilter : IObjectFilter + ) : IFilterableObjectCursor ; + + + (* + ['{4E3C49EE-5EA6-47CD-8862-3AA4F96BD86E}'] + ['{65D250B6-90AC-40DC-A6EE-4750188D1D94}'] + ['{8B4AE228-C231-45E5-B8A4-2864481B9263}'] + ['{658709D2-2D25-44DB-83CF-DC430D55A21F}'] + ['{B2CFB744-43CF-4787-8256-A0F34E26A729}'] + ['{D3A4A37A-B63A-42AD-8E44-4AD4C28E3C34}'] + ['{DB7A8303-0621-41A0-A948-A7BD71CA99F8}'] + ['{3BB114EB-73CF-4555-ABC7-ABA4A643DBDA}'] + ['{C64B6235-54BE-4DA9-A5E8-D67B579FA14F}'] + + *) + +implementation + +type + + { TSimpleObjectFilterableCursor } + + TSimpleObjectFilterableCursor = class( + TInterfacedObject, + ICursor,IObjectCursor,IFilterableObjectCursor + ) + private + FBaseCursor : IObjectCursor; + FFilter : IObjectFilter; + protected + procedure Reset(); + function MoveNext() : Boolean; + function Clone():ICursor; + function GetCurrent() : TObject; + function GetFilter() : IObjectFilter; + function SetFilter(const AFilter : IObjectFilter) : IObjectFilter; + public + constructor Create( + AInputCursor : IObjectCursor; + AFilter : IObjectFilter + ); + end; + +function CreateCursorOn( + AInputCursor : IObjectCursor; + AFilter : IObjectFilter +) : IFilterableObjectCursor ; +begin + Result := TSimpleObjectFilterableCursor.Create(AInputCursor,AFilter); +end; + + +{ TSimpleObjectFilterableCursor } + +procedure TSimpleObjectFilterableCursor.Reset(); +begin + FBaseCursor.Reset(); +end; + +function TSimpleObjectFilterableCursor.MoveNext(): Boolean; +begin + if ( FFilter = nil ) then begin + Result := FBaseCursor.MoveNext(); + end else begin + while FBaseCursor.MoveNext() do begin + if FFilter.Evaluate(FBaseCursor.GetCurrent()) then begin + Result := True; + exit; + end; + end; + Result := False; + end; +end; + +function TSimpleObjectFilterableCursor.Clone(): ICursor; +var + baseClone : ICursor; +begin + Result := nil; + baseClone := FBaseCursor.Clone(); + if ( baseClone <> nil ) then + Result := TSimpleObjectFilterableCursor.Create(baseClone as IObjectCursor,FFilter); +end; + +function TSimpleObjectFilterableCursor.GetCurrent(): TObject; +begin + Result := FBaseCursor.GetCurrent(); +end; + +function TSimpleObjectFilterableCursor.GetFilter(): IObjectFilter; +begin + Result := FFilter; +end; + +function TSimpleObjectFilterableCursor.SetFilter(const AFilter: IObjectFilter): IObjectFilter; +begin + FFilter := AFilter; + Result := FFilter; +end; + +constructor TSimpleObjectFilterableCursor.Create( + AInputCursor : IObjectCursor; + AFilter : IObjectFilter +); +begin + Assert(Assigned(AInputCursor)); + inherited Create(); + FBaseCursor := AInputCursor; + FFilter := AFilter; +end; + + +end. diff --git a/wst/trunk/wst_rtti_filter/dom_cursors.pas b/wst/trunk/wst_rtti_filter/dom_cursors.pas new file mode 100644 index 000000000..00a0d6adb --- /dev/null +++ b/wst/trunk/wst_rtti_filter/dom_cursors.pas @@ -0,0 +1,257 @@ +unit dom_cursors; + +{$mode objfpc}{$H+} +//{$define FPC_211} +interface + +uses + Classes, SysUtils, + cursor_intf, DOM; + +type + + TFreeAction = ( faNone, faFreeOnDestroy ); + + { TDOMNodeListCursor } + + TDOMNodeListCursor = class(TInterfacedObject,ICursor,IObjectCursor) + private + FList : TDOMNodeList; + FCurrent : TDOMNode; + FFreeListOnDestroy : TFreeAction; + FHasItem : Boolean; + protected + procedure Reset(); + function MoveNext() : Boolean; + function Clone():ICursor; + function GetCurrent() : TObject;virtual; + public + constructor Create( + ADataList : TDOMNodeList; + const AFreeListOnDestroy : TFreeAction + ); + destructor Destroy();override; + end; + + { TDOMNamedNodeMapCursor } + + TDOMNamedNodeMapCursor = class(TInterfacedObject,ICursor,IObjectCursor) + private + FList : TDOMNamedNodeMap; + FCurrent : Integer; + FFreeListOnDestroy : TFreeAction; + protected + procedure Reset(); + function MoveNext() : Boolean; + function Clone():ICursor; + function GetCurrent() : TObject; + public + constructor Create( + ADataList : TDOMNamedNodeMap; + const AFreeListOnDestroy : TFreeAction + ); + destructor Destroy();override; + end; + + { TDOMNodeRttiExposer } + + TDOMNodeRttiExposer = class(TPersistent) + private + FInnerObject: TDOMNode; + function GetNodeName: DOMString; + function GetNodeValue: DOMString; + procedure SetInnerObject(const AValue: TDOMNode); + public + constructor Create(AInnerObject : TDOMNode); + property InnerObject : TDOMNode read FInnerObject write SetInnerObject; + published + property NodeName: DOMString read GetNodeName; + property NodeValue: DOMString read GetNodeValue; + end; + + { TDOMNodeRttiExposerCursor } + + TDOMNodeRttiExposerCursor = class(TInterfacedObject,ICursor,IObjectCursor) + private + FCurrentExposer : TDOMNodeRttiExposer; + FBaseCursor : IObjectCursor; + protected + procedure Reset(); + function MoveNext() : Boolean; + function Clone():ICursor; + function GetCurrent() : TObject;virtual; + public + constructor Create(ADataList : IObjectCursor); + destructor Destroy();override; + end; + +implementation + +{ TDOMNodeListCursor } + +procedure TDOMNodeListCursor.Reset(); +begin + FCurrent := nil; +end; + +function TDOMNodeListCursor.MoveNext(): Boolean; +begin + if ( FCurrent = nil ) then begin + if FHasItem then + FCurrent := FList.Item[0]; + end else begin + FCurrent := FCurrent.NextSibling; + end; + Result := ( FCurrent <> nil ) ; +end; + +function TDOMNodeListCursor.Clone(): ICursor; +begin + Result := TDOMNodeListCursor.Create(FList,faNone); +end; + +function TDOMNodeListCursor.GetCurrent(): TObject; +begin + Result := FCurrent; +end; + +constructor TDOMNodeListCursor.Create( + ADataList : TDOMNodeList; + const AFreeListOnDestroy : TFreeAction +); +begin + Assert(Assigned(ADataList)); + FFreeListOnDestroy := AFreeListOnDestroy; + FList := ADataList; + FHasItem := ( FList.Count > 0 ); + Reset(); +end; + +destructor TDOMNodeListCursor.Destroy(); +begin + FCurrent := nil; + if ( FFreeListOnDestroy = faFreeOnDestroy ) then + FreeAndNil(FList) + else + FList := nil; + inherited Destroy(); +end; + +{ TDOMNodeRttiExposer } + +function TDOMNodeRttiExposer.GetNodeName: DOMString; +begin + Result := InnerObject.NodeName; +end; + +function TDOMNodeRttiExposer.GetNodeValue: DOMString; +begin + Result := InnerObject.NodeValue; +end; + +procedure TDOMNodeRttiExposer.SetInnerObject(const AValue: TDOMNode); +begin + if ( FInnerObject = AValue ) then + exit; + FInnerObject := AValue; +end; + +constructor TDOMNodeRttiExposer.Create(AInnerObject: TDOMNode); +begin + Inherited Create(); + SetInnerObject(AInnerObject); +end; + +{ TDOMNodeRttiExposerCursor } + +procedure TDOMNodeRttiExposerCursor.Reset(); +begin + FBaseCursor.Reset(); +end; + +function TDOMNodeRttiExposerCursor.MoveNext(): Boolean; +begin + Result := FBaseCursor.MoveNext(); +end; + +function TDOMNodeRttiExposerCursor.Clone(): ICursor; +var + baseClone : ICursor; +begin + Result := nil; + baseClone := FBaseCursor.Clone(); + if ( baseClone <> nil ) then + Result := TDOMNodeRttiExposerCursor.Create(baseClone as IObjectCursor) ; +end; + +function TDOMNodeRttiExposerCursor.GetCurrent(): TObject; +begin + FCurrentExposer.InnerObject := FBaseCursor.GetCurrent() as TDOMNode; + if ( FCurrentExposer.InnerObject = nil ) then + Result := nil + else + Result := FCurrentExposer; +end; + +constructor TDOMNodeRttiExposerCursor.Create(ADataList : IObjectCursor); +begin + Assert(Assigned(ADataList)); + inherited Create(); + FBaseCursor := ADataList; + FCurrentExposer := TDOMNodeRttiExposer.Create(nil); +end; + +destructor TDOMNodeRttiExposerCursor.Destroy(); +begin + FreeAndNil(FCurrentExposer);; + inherited Destroy(); +end; + +{ TDOMNamedNodeMapCursor } + +procedure TDOMNamedNodeMapCursor.Reset(); +begin + FCurrent := -1; +end; + +function TDOMNamedNodeMapCursor.MoveNext(): Boolean; +begin + Inc(FCurrent); + Result := ( FCurrent < FList.{$IFNDEF FPC_211}Count{$ELSE}Length{$ENDIF} ); +end; + +function TDOMNamedNodeMapCursor.Clone(): ICursor; +begin + Result := TDOMNamedNodeMapCursor.Create(FList,faNone); +end; + +function TDOMNamedNodeMapCursor.GetCurrent(): TObject; +begin + if ( FCurrent > -1 ) and ( FCurrent < FList.{$IFNDEF FPC_211}Count{$ELSE}Length{$ENDIF} ) then + Result := FList.Item[FCurrent] + else + Result := nil; +end; + +constructor TDOMNamedNodeMapCursor.Create( + ADataList : TDOMNamedNodeMap; + const AFreeListOnDestroy : TFreeAction +); +begin + Assert(Assigned(ADataList)); + FFreeListOnDestroy := AFreeListOnDestroy; + FList := ADataList; + Reset(); +end; + +destructor TDOMNamedNodeMapCursor.Destroy(); +begin + if ( FFreeListOnDestroy = faFreeOnDestroy ) then + FreeAndNil(FList) + else + FList := nil; + inherited Destroy(); +end; + +end. + diff --git a/wst/trunk/wst_rtti_filter/rtti_filters.pas b/wst/trunk/wst_rtti_filter/rtti_filters.pas new file mode 100644 index 000000000..2cae5ede8 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/rtti_filters.pas @@ -0,0 +1,655 @@ +unit rtti_filters; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Contnrs, TypInfo, + cursor_intf; + +type + + ERttiFilterException = class(Exception) + end; + + TFilterConnector = ( fcNone, fcAnd, fcOr ); + + TNumericFilterOperator = ( nfoEqual, nfoGreater, nfoLesser, nfoNotEqual ); + TStringFilterOperator = ( sfoEqualCaseSensitive, sfoEqualCaseInsensitive, sfoNotEqual ); + + TRttiFilterCreatorTarget = TPersistent; + TRttiFilterCreatorTargetClass = class of TRttiFilterCreatorTarget; + + TRttiExpNodeItem = class; + TRttiExpNode = class; + + TClearAction = ( clrNone, clrFreeObjects ); + + { TRttiFilterCreator } + TRttiFilterCreator = class + private + FRoot : TRttiExpNode; + FCurrent : TRttiExpNode; + FTargetClass: TRttiFilterCreatorTargetClass; + FCurrentStack : TObjectStack; + private + procedure AddNode( + const ANode : TRttiExpNodeItem; + const AConnector : TFilterConnector + ); + procedure PushCurrent(ACurrent : TRttiExpNode); + function PopCurrent() : TRttiExpNode; + public + constructor Create(const ATargetClass : TRttiFilterCreatorTargetClass); + destructor Destroy();override; + procedure Clear(const AFreeObjects : TClearAction); + function AddCondition( + const APropertyName : string; + const AOperator : TNumericFilterOperator; + const AValue : Integer; + const AConnector : TFilterConnector + ) : TRttiFilterCreator;overload; + function AddCondition( + const APropertyName : string; + const AOperator : TStringFilterOperator; + const AValue : AnsiString; + const AConnector : TFilterConnector + ) : TRttiFilterCreator;overload; + function AddCondition( + const APropertyName : string; + const AOperator : TStringFilterOperator; + const AValue : WideString; + const AConnector : TFilterConnector + ) : TRttiFilterCreator;overload; + + function BeginGroup(const AConnector : TFilterConnector):TRttiFilterCreator; + function EndGroup():TRttiFilterCreator; + property TargetClass : TRttiFilterCreatorTargetClass read FTargetClass; + property Root : TRttiExpNode read FRoot; + end; + + + TRttiExpNodeItem = class + public + function Evaluate(AInstance : TRttiFilterCreatorTarget):Boolean;virtual;abstract; + end; + + { TRttiObjectFilter } + + TRttiObjectFilter = class(TInterfacedObject,IObjectFilter) + private + FFilterRoot : TRttiExpNodeItem; + FOnDestroyFilterAction : TClearAction; + protected + function Evaluate(const AObject : TObject) : Boolean; + public + constructor Create( + AFilterRoot : TRttiExpNodeItem; + const AOnDestroyFilterAction : TClearAction + ); + destructor Destroy();override; + end; + + { TRttiExpNode } + + TRttiExpNode = class(TRttiExpNodeItem) + private + FConnector: TFilterConnector; + FLeft: TRttiExpNodeItem; + FRight: TRttiExpNodeItem; + private + procedure SetConnector(const AValue: TFilterConnector); + procedure SetLeft(const AValue: TRttiExpNodeItem); + procedure SetRight(const AValue: TRttiExpNodeItem); + public + destructor Destroy();override; + function Evaluate(AInstance : TRttiFilterCreatorTarget):Boolean;override; + property Connector : TFilterConnector read FConnector write SetConnector; + property Left : TRttiExpNodeItem read FLeft write SetLeft; + property Right : TRttiExpNodeItem read FRight write SetRight; + end; + + { TRttiExpConcreteNodeItem } + + TRttiExpConcreteNodeItem = class(TRttiExpNodeItem) + private + FPropInfo: PPropInfo; + public + constructor Create(const APropInfo : PPropInfo); + property PropInfo : PPropInfo read FPropInfo; + end; + + { TRttiExpNumericNodeItem } + + TRttiExpNumericNodeItem = class(TRttiExpConcreteNodeItem) + private + FOperation: TNumericFilterOperator; + public + constructor Create( + const APropInfo : PPropInfo; + const AOperation : TNumericFilterOperator + ); + property Operation : TNumericFilterOperator read FOperation; + end; + + { TRttiExpIntegerNodeItem } + + TRttiExpIntegerNodeItem = class(TRttiExpNumericNodeItem) + private + FComparedValue: Integer; + public + constructor Create( + const APropInfo : PPropInfo; + const AOperation : TNumericFilterOperator; + const AComparedValue : Integer + ); + function Evaluate(AInstance : TRttiFilterCreatorTarget):Boolean;override; + property ComparedValue : Integer read FComparedValue; + end; + + { TRttiExpStringNodeItem } + + TRttiExpStringNodeItem = class(TRttiExpConcreteNodeItem) + private + FOperation: TStringFilterOperator; + public + constructor Create( + const APropInfo : PPropInfo; + const AOperation : TStringFilterOperator + ); + property Operation : TStringFilterOperator read FOperation; + end; + + { TRttiExpAnsiStringNodeItem } + + TRttiExpAnsiStringNodeItem = class(TRttiExpStringNodeItem) + private + FComparedValue: AnsiString; + public + constructor Create( + const APropInfo : PPropInfo; + const AOperation : TStringFilterOperator; + const AComparedValue : AnsiString + ); + function Evaluate(AInstance : TRttiFilterCreatorTarget):Boolean;override; + property ComparedValue : AnsiString read FComparedValue; + end; + + { TRttiExpWideStringNodeItem } + + TRttiExpWideStringNodeItem = class(TRttiExpStringNodeItem) + private + FComparedValue: WideString; + public + constructor Create( + const APropInfo : PPropInfo; + const AOperation : TStringFilterOperator; + const AComparedValue : WideString + ); + function Evaluate(AInstance : TRttiFilterCreatorTarget):Boolean;override; + property ComparedValue : WideString read FComparedValue; + end; + + procedure ParseFilter(const AFilterText: string; AFltrCrtr : TRttiFilterCreator);overload; + function ParseFilter( + const AFilterText : string; + ATargetClass : TRttiFilterCreatorTargetClass + ) : IObjectFilter;overload; + +implementation + +function ParseFilter( + const AFilterText : string; + ATargetClass : TRttiFilterCreatorTargetClass +) : IObjectFilter; +var + fltr : TRttiFilterCreator; +begin + Result := nil; + fltr := TRttiFilterCreator.Create(ATargetClass); + try + try + ParseFilter(AFilterText,fltr); + Result := TRttiObjectFilter.Create(fltr.Root,clrFreeObjects); + fltr.Clear(clrNone); + except + fltr.Clear(clrFreeObjects); + end; + finally + FreeAndNil(fltr); + end; +end; + +procedure ParseFilter(const AFilterText: string; AFltrCrtr : TRttiFilterCreator); +const + tkn_LeftParenthesis = '('; tkn_RigthParenthesis = ')'; + tkn_Equal = '='; tkn_NotEqual = '<>'; + tkn_Sup = '>'; tkn_Inf = '<'; + tkn_And = 'and'; tkn_Or = 'or'; +var + strm : TStringStream; + prsr : TParser; + + procedure MoveNext(); + begin + prsr.NextToken(); + if ( prsr.Token = toEOF ) then + raise ERttiFilterException.Create('Unexpected end of filter.'); + end; + +var + propName : string; + propInfo : PPropInfo; + lastCntr : TFilterConnector; + + procedure Handle_String(); + var + s : string; + ws : WideString; + fltrOp : TStringFilterOperator; + begin + MoveNext(); + s := prsr.TokenString(); + if ( s = tkn_Equal ) then + fltrOp := sfoEqualCaseInsensitive + else if ( s = tkn_NotEqual ) then + fltrOp := sfoNotEqual + else + raise ERttiFilterException.CreateFmt('Unexpected symbol : "%s".',[s]); + MoveNext(); + prsr.CheckToken(toString); + if ( propInfo^.PropType^.Kind = tkWString ) then begin + ws := prsr.TokenString(); + AFltrCrtr.AddCondition(propName,fltrOp,ws,lastCntr); + end else begin + s := prsr.TokenString(); + AFltrCrtr.AddCondition(propName,fltrOp,s,lastCntr); + end; + end; + + procedure Handle_Integer(); + var + s : string; + fltrOp : TNumericFilterOperator; + begin + MoveNext(); + s := prsr.TokenString(); + if ( s = tkn_Equal ) then + fltrOp := nfoEqual + else if ( s = tkn_NotEqual ) then + fltrOp := nfoNotEqual + else if ( s = tkn_Inf ) then + fltrOp := nfoLesser + else if ( s = tkn_Sup ) then + fltrOp := nfoGreater + else + raise ERttiFilterException.CreateFmt('Unexpected symbol : "%s".',[s]); + MoveNext(); + prsr.CheckToken(toInteger); + AFltrCrtr.AddCondition(propName,fltrOp,prsr.TokenInt(),lastCntr); + end; + +var + s : string; +begin + lastCntr := fcAnd; + AFltrCrtr.Clear(clrFreeObjects); + strm := TStringStream.Create(Trim(AFilterText)); + try + prsr := TParser.Create(strm); + while ( prsr.Token <> toEOF ) do begin + s := prsr.TokenString(); + if SameText(s,tkn_LeftParenthesis) then + AFltrCrtr.BeginGroup(lastCntr) + else if SameText(s,tkn_RigthParenthesis) then + AFltrCrtr.EndGroup() + else if SameText(s,tkn_And) then + lastCntr := fcAnd + else if SameText(s,tkn_Or) then + lastCntr := fcOr + else begin + prsr.CheckToken(toSymbol); + propName := prsr.TokenString(); + propInfo := GetPropInfo(AFltrCrtr.TargetClass,propName); + if ( propInfo = nil ) then + raise ERttiFilterException.CreateFmt('Invalid property : "%s"',[propName]); + if ( propInfo^.PropType^.Kind in [tkSString,tkLString,tkAString,tkWString] ) then + Handle_String() + else if ( propInfo^.PropType^.Kind in [tkInteger,tkInt64,tkQWord] ) then + Handle_Integer() + else + raise ERttiFilterException.CreateFmt('Type not handled : "%s"',[GetEnumName(TypeInfo(TTypeKind),Ord(propInfo^.PropType^.Kind))]); + end; + prsr.NextToken(); + end; + finally + FreeAndNil(strm); + end; +end; + +procedure ClearObject(ARoot : TRttiExpNodeItem); +begin + if Assigned(ARoot) then begin + if ARoot.InheritsFrom(TRttiExpNode) then begin + with TRttiExpNode(ARoot) do begin + ClearObject(Right); + Right := nil; + ClearObject(Left); + Left := nil; + end; + end; + ARoot.Free(); + end; +end; + +{ TRttiExpNode } + +procedure TRttiExpNode.SetRight(const AValue: TRttiExpNodeItem); +begin + if ( Connector = fcNone ) and ( AValue <> nil ) then + raise ERttiFilterException.Create('"Connector" must be set before "Right".'); + //FreeAndNil(FRight); + FRight := AValue; +end; + +procedure TRttiExpNode.SetConnector(const AValue: TFilterConnector); +begin + if ( AValue = fcNone ) and ( FRight <> nil ) then + raise ERttiFilterException.Create('"Right" must be set to "nil" before "Connector" can be set to "none".'); + FConnector := AValue; +end; + +procedure TRttiExpNode.SetLeft(const AValue: TRttiExpNodeItem); +begin + if ( FRight <> nil ) and ( AValue = nil ) then + raise ERttiFilterException.Create('"Right" must be set to "nil" before "Left" can be set to "none".'); + //FreeAndNil(FLeft); + FLeft := AValue; +end; + +destructor TRttiExpNode.Destroy(); +begin + FreeAndNil(FLeft); + FreeAndNil(FRight); + inherited Destroy(); +end; + +function TRttiExpNode.Evaluate(AInstance: TRttiFilterCreatorTarget): Boolean; +begin + if Assigned(Left) then begin + Result := Left.Evaluate(AInstance); + if not Assigned(Right) then + Exit; + if Result and ( Connector = fcOr ) then + Exit; + if ( not Result ) and ( Connector = fcAnd ) then + Exit; + Result := Right.Evaluate(AInstance); + end else begin + Result := False; + end; +end; + +{ TRttiExpConcreteNodeItem } + +constructor TRttiExpConcreteNodeItem.Create(const APropInfo : PPropInfo); +begin + Assert(Assigned(APropInfo)); + FPropInfo := APropInfo; +end; + +{ TRttiExpIntegerNodeItem } + +constructor TRttiExpIntegerNodeItem.Create( + const APropInfo : PPropInfo; + const AOperation : TNumericFilterOperator; + const AComparedValue : Integer +); +begin + Assert(Assigned(APropInfo)); + if not ( APropInfo^.PropType^.Kind in [tkInteger,tkInt64,tkQWord] ) then + raise ERttiFilterException.CreateFmt('Invalid property data type. "%s" excpeted.',['Integer']); + inherited Create(APropInfo,AOperation); + FComparedValue := AComparedValue; +end; + +function TRttiExpIntegerNodeItem.Evaluate(AInstance: TRttiFilterCreatorTarget): Boolean; +begin + case Operation of + nfoEqual : Result := ( GetOrdProp(AInstance,PropInfo) = ComparedValue ); + nfoGreater : Result := ( GetOrdProp(AInstance,PropInfo) > ComparedValue ); + nfoLesser : Result := ( GetOrdProp(AInstance,PropInfo) < ComparedValue ); + nfoNotEqual : Result := ( GetOrdProp(AInstance,PropInfo) <> ComparedValue ); + end; +end; + +{ TRttiFilterCreator } + +procedure TRttiFilterCreator.AddNode( + const ANode : TRttiExpNodeItem; + const AConnector : TFilterConnector +); +var + tmpNode : TRttiExpNode; +begin + Assert(Assigned(ANode)); + if not Assigned(FRoot) then begin + FRoot := TRttiExpNode.Create(); + FCurrent := FRoot; + end; + if not Assigned(FCurrent.Left) then begin + FCurrent.Left := ANode; + FCurrent.Connector := AConnector; + Exit; + end; + if ( AConnector <= fcNone ) then + raise ERttiFilterException.Create('Invalid connector value.'); + if not Assigned(FCurrent.Right) then begin + FCurrent.Right := ANode; + FCurrent.Connector := AConnector; + Exit; + end; + tmpNode := TRttiExpNode.Create(); + tmpNode.Left := FCurrent.Right; + FCurrent.Right := tmpNode; + FCurrent := tmpNode; + FCurrent.Connector := AConnector; + FCurrent.Right := ANode; +end; + +procedure TRttiFilterCreator.PushCurrent(ACurrent: TRttiExpNode); +begin + FCurrentStack.Push(FCurrent); + FCurrent := ACurrent; +end; + +function TRttiFilterCreator.PopCurrent(): TRttiExpNode; +begin + if not FCurrentStack.AtLeast(1) then + raise ERttiFilterException.Create('"BeginGroup" must be called before "EndGroup".'); + Result := FCurrentStack.Pop() as TRttiExpNode; + FCurrent := Result; +end; + +constructor TRttiFilterCreator.Create(const ATargetClass: TRttiFilterCreatorTargetClass); +begin + Assert(Assigned(ATargetClass)); + FTargetClass := ATargetClass; + FCurrentStack := TObjectStack.Create(); +end; + +destructor TRttiFilterCreator.Destroy(); +begin + FreeAndNil(FCurrentStack); + inherited Destroy(); +end; + +procedure TRttiFilterCreator.Clear(const AFreeObjects: TClearAction); +var + i : Integer; +begin + if ( AFreeObjects = clrFreeObjects ) then + ClearObject(FRoot); + for i := 0 to Pred(FCurrentStack.Count) do + FCurrentStack.Pop(); + FRoot := nil; +end; + +function TRttiFilterCreator.AddCondition( + const APropertyName : string; + const AOperator : TNumericFilterOperator; + const AValue : Integer; + const AConnector : TFilterConnector +) : TRttiFilterCreator; +begin + AddNode( + TRttiExpIntegerNodeItem.Create(GetPropInfo(TargetClass,APropertyName),AOperator,AValue), + AConnector + ); + Result := Self; +end; + +function TRttiFilterCreator.AddCondition( + const APropertyName : string; + const AOperator : TStringFilterOperator; + const AValue : AnsiString; + const AConnector : TFilterConnector +): TRttiFilterCreator; +begin + AddNode( + TRttiExpAnsiStringNodeItem.Create(GetPropInfo(TargetClass,APropertyName),AOperator,AValue), + AConnector + ); + Result := Self; +end; + +function TRttiFilterCreator.AddCondition( + const APropertyName : string; + const AOperator : TStringFilterOperator; + const AValue : WideString; + const AConnector : TFilterConnector +): TRttiFilterCreator; +begin + AddNode( + TRttiExpWideStringNodeItem.Create(GetPropInfo(TargetClass,APropertyName),AOperator,AValue), + AConnector + ); + Result := Self; +end; + +function TRttiFilterCreator.BeginGroup(const AConnector: TFilterConnector):TRttiFilterCreator; +var + gn : TRttiExpNode; +begin + if not Assigned(FCurrent) then + AddNode(TRttiExpNode.Create(),fcNone); + gn := TRttiExpNode.Create(); + AddNode(gn,AConnector); + PushCurrent(gn); + Result := Self; +end; + +function TRttiFilterCreator.EndGroup(): TRttiFilterCreator; +begin + PopCurrent(); + Result := Self; +end; + +{ TRttiObjectFilter } + +function TRttiObjectFilter.Evaluate(const AObject: TObject): Boolean; +begin + Result := FFilterRoot.Evaluate(TRttiFilterCreatorTarget(AObject)); +end; + +constructor TRttiObjectFilter.Create( + AFilterRoot : TRttiExpNodeItem; + const AOnDestroyFilterAction : TClearAction +); +begin + Assert(Assigned(AFilterRoot)); + FFilterRoot := AFilterRoot; + FOnDestroyFilterAction := AOnDestroyFilterAction; +end; + +destructor TRttiObjectFilter.Destroy(); +begin + if ( FOnDestroyFilterAction = clrFreeObjects ) then + ClearObject(FFilterRoot); + inherited Destroy(); +end; + +{ TRttiExpNumericNodeItem } + +constructor TRttiExpNumericNodeItem.Create( + const APropInfo: PPropInfo; + const AOperation: TNumericFilterOperator +); +begin + Assert(Assigned(APropInfo)); + inherited Create(APropInfo); + FOperation := AOperation; +end; + +{ TRttiExpStringNodeItem } + +constructor TRttiExpStringNodeItem.Create( + const APropInfo: PPropInfo; + const AOperation: TStringFilterOperator +); +begin + Assert(Assigned(APropInfo)); + inherited Create(APropInfo); + FOperation := AOperation; +end; + +{ TRttiExpAnsiStringNodeItem } + +constructor TRttiExpAnsiStringNodeItem.Create( + const APropInfo: PPropInfo; + const AOperation: TStringFilterOperator; + const AComparedValue: AnsiString +); +begin + Assert(Assigned(APropInfo)); + if not ( APropInfo^.PropType^.Kind in [tkSString,tkLString,tkAString] ) then + raise ERttiFilterException.CreateFmt('Invalid property data type. "%s" excpeted.',['AnsiString']); + inherited Create(APropInfo,AOperation); + FComparedValue := AComparedValue; +end; + +function TRttiExpAnsiStringNodeItem.Evaluate(AInstance: TRttiFilterCreatorTarget): Boolean; +begin + case Operation of + sfoEqualCaseSensitive : Result := ( GetStrProp(AInstance,PropInfo) = ComparedValue ); + sfoEqualCaseInsensitive : Result := AnsiSameText(GetStrProp(AInstance,PropInfo),ComparedValue); + sfoNotEqual : Result := ( GetStrProp(AInstance,PropInfo) <> ComparedValue); + end; +end; + +{ TRttiExpWideStringNodeItem } + +constructor TRttiExpWideStringNodeItem.Create( + const APropInfo: PPropInfo; + const AOperation: TStringFilterOperator; + const AComparedValue: WideString +); +begin + Assert(Assigned(APropInfo)); + if not ( APropInfo^.PropType^.Kind in [tkWString] ) then + raise ERttiFilterException.CreateFmt('Invalid property data type. "%s" excpeted.',['WideString']); + inherited Create(APropInfo,AOperation); + FComparedValue := AComparedValue; +end; + +function TRttiExpWideStringNodeItem.Evaluate(AInstance: TRttiFilterCreatorTarget): Boolean; +begin + case Operation of + sfoEqualCaseSensitive : Result := ( GetStrProp(AInstance,PropInfo) = ComparedValue ); + sfoEqualCaseInsensitive : Result := WideSameText(GetStrProp(AInstance,PropInfo),ComparedValue); + sfoNotEqual : Result := ( GetStrProp(AInstance,PropInfo) <> ComparedValue ); + end; +end; + +end. diff --git a/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpi b/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpi new file mode 100644 index 000000000..ba1852574 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpi @@ -0,0 +1,266 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpr b/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpr new file mode 100644 index 000000000..35822b094 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/rtti_filters_tests.lpr @@ -0,0 +1,159 @@ +program rtti_filters_tests; + +{$mode objfpc}{$H+} +//{$DEFINE VER2_0} +uses + custapp, Classes, SysUtils, fpcunit, testreport, testregistry, tests, + cursor_intf, rtti_filters, std_cursors, test_std_cursors, dom_cursors; + +const + ShortOpts = 'alh'; + Longopts: array[1..5] of string = ('all', 'list', 'format:', 'suite:', 'help'); + Version = 'Version 0.1'; + +type + TFormat = (fPlain, fLatex, fXML); + + TTestRunner = class(TCustomApplication) + private + protected + procedure DoRun; override; + procedure doTestRun(aTest: TTest); virtual; + public + end; + +var + FormatParam: TFormat; + + procedure TTestRunner.doTestRun(aTest: TTest); + var + testResult: TTestResult; + + procedure doXMLTestRun(aText: TTest); + var + XMLResultsWriter: TXMLResultsWriter; + begin + try + XMLResultsWriter := TXMLResultsWriter.Create; + testResult.AddListener(XMLResultsWriter); + XMLResultsWriter.WriteHeader; + aTest.Run(testResult); + XMLResultsWriter.WriteResult(testResult); + finally + XMLResultsWriter.Free; + testResult.Free; + end; + end; + + {$IFNDEF VER2_0} + procedure doPlainTestRun(aText: TTest); + var + PlainResultsWriter: TPlainResultsWriter; + begin + try + PlainResultsWriter := TPlainResultsWriter.Create; + testResult.AddListener(PlainResultsWriter); + PlainResultsWriter.WriteHeader; + aTest.Run(testResult); + PlainResultsWriter.WriteResult(testResult); + finally + PlainResultsWriter.Free; + testResult.Free; + end; + end; + {$ENDIF} + + begin + testResult := TTestResult.Create; + + case FormatParam of + fLatex: doXMLTestRun(aTest); //no latex implemented yet + {$IFNDEF VER2_0} + fPlain: doPlainTestRun(aTest); + {$ENDIF} + else + doXMLTestRun(aTest); + end; + end; + + procedure TTestRunner.DoRun; + var + I: integer; + S: string; + begin + S := CheckOptions(ShortOpts, LongOpts); + if (S <> '') then + Writeln(S); + + if HasOption('h', 'help') or (ParamCount = 0) then + begin + writeln(Title); + writeln(Version); + writeln; + writeln('Usage: '); + writeln(' --format=latex output as latex source (only list implemented)'); + {$IFNDEF VER2_0} + writeln(' --format=plain output as plain ASCII source'); + {$ENDIF} + writeln(' --format=xml output as XML source (default)'); + writeln; + writeln(' -l or --list show a list of registered tests'); + writeln(' -a or --all run all tests'); + writeln(' --suite=MyTestSuiteName run single test suite class'); + writeln; + writeln('The results can be redirected to an xml file,'); + writeln('for example: ./testrunner --all > results.xml'); + end; + + //get the format parameter + FormatParam := fXML; + if HasOption('format') then + begin + if GetOptionValue('format') = 'latex' then + FormatParam := fLatex; + {$IFNDEF VER2_0} + if GetOptionValue('format') = 'plain' then + FormatParam := fPlain; + {$ENDIF} + end; + + //get a list of all registed tests + if HasOption('l', 'list') then + case FormatParam of + fLatex: Write(GetSuiteAsLatex(GetTestRegistry)); + {$IFNDEF VER2_0} + fPlain: Write(GetSuiteAsPlain(GetTestRegistry)); + {$ENDIF} + else + Write(GetSuiteAsXML(GetTestRegistry)); + end; + + //run the tests + if HasOption('a', 'all') then + doTestRun(GetTestRegistry) + else + if HasOption('suite') then + begin + S := ''; + S := GetOptionValue('suite'); + if S = '' then + for I := 0 to GetTestRegistry.Tests.Count - 1 do + writeln(GetTestRegistry[i].TestName) + else + for I := 0 to GetTestRegistry.Tests.Count - 1 do + if GetTestRegistry[i].TestName = S then + doTestRun(GetTestRegistry[i]); + end; + Terminate; + end; + +var + App: TTestRunner; + +begin + App := TTestRunner.Create(nil); + App.Initialize; + App.Title := 'FPCUnit Console Test Case runner.'; + App.Run; + App.Free; +end. diff --git a/wst/trunk/wst_rtti_filter/rtti_filters_tests.pas b/wst/trunk/wst_rtti_filter/rtti_filters_tests.pas new file mode 100644 index 000000000..d0a08e5a8 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/rtti_filters_tests.pas @@ -0,0 +1,11 @@ +program rtti_filters_tests; + +{$mode objfpc}{$H+} + +uses + Classes, SysUtils, + cursor_intf, rtti_filters; + +begin +end. + diff --git a/wst/trunk/wst_rtti_filter/std_cursors.pas b/wst/trunk/wst_rtti_filter/std_cursors.pas new file mode 100644 index 000000000..05d3e94e2 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/std_cursors.pas @@ -0,0 +1,112 @@ +unit std_cursors; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Contnrs, + cursor_intf; + +type + + { TObjectListCursor } + + TObjectListCursor = class(TInterfacedObject,ICursor,IObjectCursor) + private + FList : TObjectList; + FCurrentIndex : Integer; + protected + procedure Reset(); + function MoveNext() : Boolean;virtual; + function Clone():ICursor; + function GetCurrent() : TObject; + public + constructor Create(ADataList : TObjectList); + end; + + { TObjectListFilterableCursor } + + TObjectListFilterableCursor = class(TObjectListCursor,IFilterableObjectCursor) + private + FFilter : IObjectFilter; + protected + function MoveNext() : Boolean;override; + function GetFilter() : IObjectFilter; + function SetFilter(const AFilter : IObjectFilter) : IObjectFilter; + public + destructor Destroy();override; + end; + +implementation + +{ TObjectListCursor } + +procedure TObjectListCursor.Reset(); +begin + FCurrentIndex := -1; +end; + +function TObjectListCursor.MoveNext(): Boolean; +begin + Inc(FCurrentIndex); + Result := ( FCurrentIndex < FList.Count ); +end; + +function TObjectListCursor.Clone(): ICursor; +begin + Result := TObjectListCursor.Create(FList); +end; + +function TObjectListCursor.GetCurrent(): TObject; +begin + if ( FCurrentIndex < 0 ) or ( FCurrentIndex >= FList.Count ) then + raise ECursorException.Create('Invalid cursor state.'); + Result := FList[FCurrentIndex]; +end; + +constructor TObjectListCursor.Create(ADataList: TObjectList); +begin + Assert(Assigned(ADataList)); + FList := ADataList; + Reset(); +end; + +{ TObjectListFilterableCursor } + +function TObjectListFilterableCursor.MoveNext(): Boolean; +begin + if ( FFilter = nil ) then begin + Result := inherited MoveNext(); + end else begin + while ( inherited MoveNext() ) do begin + if FFilter.Evaluate(GetCurrent()) then begin + Result := True; + Exit; + end; + end; + Result := False; + end; +end; + +function TObjectListFilterableCursor.GetFilter(): IObjectFilter; +begin + Result := FFilter; +end; + +function TObjectListFilterableCursor.SetFilter( + const AFilter: IObjectFilter +): IObjectFilter; +begin + FFilter := AFilter; + Result := FFilter; +end; + +destructor TObjectListFilterableCursor.Destroy(); +begin + FFilter := nil; + inherited Destroy(); +end; + +end. + diff --git a/wst/trunk/wst_rtti_filter/test_std_cursors.pas b/wst/trunk/wst_rtti_filter/test_std_cursors.pas new file mode 100644 index 000000000..8b186a6ea --- /dev/null +++ b/wst/trunk/wst_rtti_filter/test_std_cursors.pas @@ -0,0 +1,232 @@ +unit test_std_cursors; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Contnrs, + fpcunit, testutils, testregistry, + cursor_intf, std_cursors, rtti_filters; + +type + + { TClass_A } + + TClass_A = class(TPersistent) + private + FIntProp: Integer; + public + constructor Create(AIntProp : Integer); + published + property IntProp : Integer read FIntProp; + end; + + { TClass_B } + + TClass_B = class(TClass_A) + private + FIntProp_A: Integer; + FIntProp_B: Integer; + public + constructor Create(AIntProp,AIntProp_A,AIntProp_B : Integer); + published + property IntProp_A : Integer read FIntProp_A; + property IntProp_B : Integer read FIntProp_B; + end; + + { TObjectListCursor_Test } + + TObjectListCursor_Test = class(TTestCase) + published + procedure All(); + end; + + { TObjectListFilterableCursor_Test } + + TObjectListFilterableCursor_Test = class(TTestCase) + published + procedure All(); + end; + +implementation + +{ TClass_A } + +constructor TClass_A.Create(AIntProp: Integer); +begin + FIntProp := AIntProp; +end; + +{ TObjectListCursor_Test } + +procedure TObjectListCursor_Test.All(); +const O_COUNT = 100; +var + x : IObjectCursor; + ls : TObjectList; + c, i : Integer; +begin + ls := TObjectList.Create(True); + try + x := TObjectListCursor.Create(ls); + x.Reset(); + CheckEquals(False,x.MoveNext()); + x.Reset(); + CheckEquals(False,x.MoveNext()); + CheckEquals(False,x.MoveNext()); + try + x.GetCurrent(); + Check(False); + except + on e : ECursorException do begin + // GOOD + end; + end; + + ls.Add(TClass_A.Create(0)); + x.Reset(); + CheckEquals(True,x.MoveNext()); + CheckSame(ls[0],x.GetCurrent()); + CheckEquals(False,x.MoveNext()); + try + x.GetCurrent(); + Check(False); + except + on e : ECursorException do begin + // GOOD + end; + end; + x.Reset(); + CheckEquals(True,x.MoveNext()); + CheckSame(ls[0],x.GetCurrent()); + CheckEquals(False,x.MoveNext()); + + ls.Clear(); + for i := 0 to Pred(O_COUNT) do + ls.Add(TClass_A.Create(i)); + x.Reset(); + for i := 0 to Pred(O_COUNT) do begin + CheckEquals(True,x.MoveNext()); + CheckSame(ls[i],x.GetCurrent()); + end; + CheckEquals(False,x.MoveNext()); + x.Reset(); + for i := 0 to Pred(O_COUNT) do begin + CheckEquals(True,x.MoveNext()); + CheckSame(ls[i],x.GetCurrent()); + end; + finally + ls.Free(); + end; +end; + + +{ TClass_B } + +constructor TClass_B.Create(AIntProp, AIntProp_A, AIntProp_B: Integer); +begin + inherited Create(AIntProp); + FIntProp_A := AIntProp_A; + FIntProp_B := AIntProp_B; +end; + +{ TObjectListFilterableCursor_Test } + +procedure TObjectListFilterableCursor_Test.All(); +const O_COUNT = 100; +var + x : IFilterableObjectCursor; + ls : TObjectList; + c, i : Integer; + f : IObjectFilter; + fcr : TRttiFilterCreator; +begin + fcr := nil; + ls := TObjectList.Create(True); + try + x := TObjectListFilterableCursor.Create(ls); + CheckNull(x.GetFilter()); + x.Reset(); + CheckEquals(False,x.MoveNext()); + x.Reset(); + CheckEquals(False,x.MoveNext()); + CheckEquals(False,x.MoveNext()); + try + x.GetCurrent(); + Check(False); + except + on e : ECursorException do begin + // GOOD + end; + end; + + ls.Add(TClass_A.Create(0)); + x.Reset(); + CheckEquals(True,x.MoveNext()); + CheckSame(ls[0],x.GetCurrent()); + CheckEquals(False,x.MoveNext()); + try + x.GetCurrent(); + Check(False); + except + on e : ECursorException do begin + // GOOD + end; + end; + x.Reset(); + CheckEquals(True,x.MoveNext()); + CheckSame(ls[0],x.GetCurrent()); + CheckEquals(False,x.MoveNext()); + + ls.Clear(); + for i := 0 to Pred(O_COUNT) do + ls.Add(TClass_A.Create(i)); + x.Reset(); + for i := 0 to Pred(O_COUNT) do begin + CheckEquals(True,x.MoveNext()); + CheckSame(ls[i],x.GetCurrent()); + end; + CheckEquals(False,x.MoveNext()); + x.Reset(); + for i := 0 to Pred(O_COUNT) do begin + CheckEquals(True,x.MoveNext()); + CheckSame(ls[i],x.GetCurrent()); + end; + + ls.Clear(); + for i := 0 to Pred(O_COUNT) do + ls.Add(TClass_B.Create(i,( i mod 10 ), ( i mod ( ( i + 1 ) * 2 ) ) )); + + fcr := TRttiFilterCreator.Create(TClass_B); + fcr.AddCondition('IntProp',nfoEqual,-1,fcOr);// + f := TRttiObjectFilter.Create(fcr.Root,clrFreeObjects) as IObjectFilter; + x.SetFilter(f); + Check(x.GetFilter()=f); + x.SetFilter(nil); + CheckNull(x.GetFilter()); + x.SetFilter(f); + Check(x.GetFilter()=f); + x.Reset(); + CheckEquals(False,x.MoveNext()); + + fcr.AddCondition('IntProp',nfoGreater,-1,fcOr); + x.Reset(); + CheckEquals(True,x.MoveNext()); + + x.Reset(); + for i := 0 to Pred(O_COUNT) do begin + CheckEquals(True,x.MoveNext()); + CheckSame(ls[i],x.GetCurrent()); + end; + + finally + ls.Free(); + fcr.Free(); + end; +end; + +Initialization + RegisterTests([TObjectListCursor_Test,TObjectListFilterableCursor_Test]); + +end. diff --git a/wst/trunk/wst_rtti_filter/tests.pas b/wst/trunk/wst_rtti_filter/tests.pas new file mode 100644 index 000000000..9f2572390 --- /dev/null +++ b/wst/trunk/wst_rtti_filter/tests.pas @@ -0,0 +1,900 @@ +unit tests; + +{$mode objfpc}{$H+} +//{$DEFINE DBG_DISPLAY} + +interface + +uses + Classes, SysUtils, fpcunit, testutils, testregistry, TypInfo, + + rtti_filters; + +type + + { TClass_A } + + TClass_A = class(TPersistent) + private + FIntProp: Integer; + FStrProp: string; + FWideStrProp: widestring; + published + property IntProp : Integer read FIntProp write FIntProp; + property StrProp : string read FStrProp write FStrProp; + property WideStrProp : widestring read FWideStrProp write FWideStrProp; + end; + TClass_AClass = class of TClass_A; + + { TRttiExpIntegerNodeItem_Test } + + TRttiExpIntegerNodeItem_Test = class(TTestCase) + published + procedure Create_Test(); + procedure Evaluate_Equal(); + procedure Evaluate_Lesser(); + procedure Evaluate_Greater(); + end; + + { TRttiExpAnsiStringNodeItem_Test } + + TRttiExpAnsiStringNodeItem_Test = class(TTestCase) + published + procedure Create_Test(); + procedure Evaluate_EqualCaseSensitive(); + procedure Evaluate_EqualCaseInsensitive(); + end; + + { TRttiExpwWideStringNodeItem_Test } + + TRttiExpwWideStringNodeItem_Test = class(TTestCase) + published + procedure Create_Test(); + procedure Evaluate_EqualCaseSensitive(); + procedure Evaluate_EqualCaseInsensitive(); + end; + + { TRttiExpNode_Test } + + TRttiExpNode_Test = class(TTestCase) + published + procedure Left_True(); + procedure LeftTrue_Or_RightFalse(); + procedure LeftTrue_Or_RightTrue(); + procedure LeftTrue_And_RightFalse(); + procedure LeftTrue_And_RightTrue(); + + procedure Left_False(); + procedure LeftFalse_Or_RightFalse(); + procedure LeftFalse_Or_RightTrue(); + procedure LeftFalse_And_RightFalse(); + end; + + { TRttiFilterCreator_Test } + + TRttiFilterCreator_Test = class(TTestCase) + published + procedure Creation(); + procedure AddContion(); + procedure BeginEnd_Group(); + end; + + { TRttiParser_Test } + + TRttiParser_Test = class(TTestCase) + published + procedure SimpleOperators(); + procedure BeginEnd_Group(); + end; + +implementation + +procedure TRttiExpIntegerNodeItem_Test.Create_Test(); +var + x : TRttiExpIntegerNodeItem; +begin + x := nil; + try + try + x := TRttiExpIntegerNodeItem.Create(GetPropInfo(TClass_A,'StrProp'),nfoEqual,10); + Check(False); + except + on e : EAssertionFailedError do + raise; + on e : ERttiFilterException do begin + // nothing! + end; + end; + finally + x.Free(); + end; +end; + +procedure TRttiExpIntegerNodeItem_Test.Evaluate_Equal(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpIntegerNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoEqual,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False ,'False'); + + t.IntProp := VAL_1; + Check( x.Evaluate(t) = True, 'True' ); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpIntegerNodeItem_Test.Evaluate_Lesser(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpIntegerNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = True ,'True'); + + t.IntProp := VAL_1 + 1; + Check( x.Evaluate(t) = False, 'False' ); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpIntegerNodeItem_Test.Evaluate_Greater(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpIntegerNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False, 'False' ); + + t.IntProp := VAL_1 + 1; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + + +{ TRttiExpNode_Test } + +procedure TRttiExpNode_Test.Left_True(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoEqual,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False, 'False' ); + + t.IntProp := VAL_1; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftTrue_Or_RightFalse(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + x.Connector := fcOr; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftTrue_Or_RightTrue(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + x.Connector := fcOr; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftTrue_And_RightFalse(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + x.Connector := fcAnd; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False ,'False'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftTrue_And_RightTrue(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + x.Connector := fcAnd; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.Left_False(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False, 'False' ); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftFalse_Or_RightFalse(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoEqual,VAL_1); + x.Connector := fcOr; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False ,'False'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftFalse_Or_RightTrue(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoEqual,VAL_1); + x.Connector := fcOr; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoEqual,0); + + t.IntProp := 0; + Check( x.Evaluate(t) = True ,'True'); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpNode_Test.LeftFalse_And_RightFalse(); +const VAL_1 : Integer = 1210; +var + x : TRttiExpNode; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpNode.Create(); + CheckNull(x.Left); + CheckNull(x.Right); + Check(x.Connector = fcNone); + + x.Left := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoLesser,-VAL_1); + x.Connector := fcAnd; + x.Right := TRttiExpIntegerNodeItem.Create(GetPropInfo(t,'IntProp'),nfoGreater,VAL_1); + + t.IntProp := 0; + Check( x.Evaluate(t) = False ,'False'); + finally + x.Free(); + t.Free(); + end; +end; + +{ TRttiFilterCreator_Test } + +procedure TRttiFilterCreator_Test.Creation(); +var + x : TRttiFilterCreator; +begin + x := TRttiFilterCreator.Create(TClass_A); + try + CheckNull(x.Root,'Root <> nil'); + Check(( x.TargetClass = TClass_A ), 'TargetClass'); + finally + x.Free(); + end; +end; + +procedure Display(const AMsg : string); +begin + {$IFDEF DBG_DISPLAY} + Write(AMsg); + {$ENDIF} +end; + +type TPrintProc = procedure(const AMsg : string); +procedure PrintTree( + ATree : TRttiExpNodeItem; + APrintProc : TPrintProc; + const AIndent : Integer +); +begin + if Assigned(ATree) then begin + if ATree.InheritsFrom(TRttiExpNode) then begin + APrintProc(StringOfChar('-',AIndent)); + APrintProc(GetEnumName(TypeInfo(TFilterConnector),Ord(TRttiExpNode(ATree).Connector)) + #10#13); + PrintTree(TRttiExpNode(ATree).Left,APrintProc,AIndent+2); + PrintTree(TRttiExpNode(ATree).Right,APrintProc,AIndent+2); + end else if ATree.InheritsFrom(TRttiExpConcreteNodeItem) then begin + APrintProc(StringOfChar('-',AIndent)); + if ATree.InheritsFrom(TRttiExpNumericNodeItem) then begin + APrintProc(TRttiExpConcreteNodeItem(ATree).PropInfo^.Name + ' ' + GetEnumName(TypeInfo(TNumericFilterOperator),Ord(TRttiExpNumericNodeItem(ATree).Operation)) ); + end else if ATree.InheritsFrom(TRttiExpStringNodeItem) then begin + APrintProc(TRttiExpConcreteNodeItem(ATree).PropInfo^.Name + ' ' + GetEnumName(TypeInfo(TStringFilterOperator),Ord(TRttiExpStringNodeItem(ATree).Operation)) ) + end; + if ATree.InheritsFrom(TRttiExpIntegerNodeItem) then + APrintProc(' ' + IntToStr(TRttiExpIntegerNodeItem(ATree).ComparedValue)) + else if ATree.InheritsFrom(TRttiExpAnsiStringNodeItem) then + APrintProc(' ' + QuotedStr(TRttiExpAnsiStringNodeItem(ATree).ComparedValue)); + APrintProc(#10#13); + end; + end; +end; + +procedure CompareTree(ATreeA,ATreeB : TRttiExpNodeItem); +begin + if ( ( ATreeA = nil ) and ( ATreeB <> nil ) ) or + ( ( ATreeB = nil ) and ( ATreeA <> nil ) ) + then begin + raise Exception.Create('not equal'); + end; + if ( ATreeA <> nil ) then begin + if ATreeA.ClassType <> ATreeB.ClassType then + raise Exception.Create('Class not equal'); + if ATreeA.InheritsFrom(TRttiExpNode) then begin + if TRttiExpNode(ATreeA).Connector <> + TRttiExpNode(ATreeB).Connector + then + raise Exception.Create('TRttiExpNode not equal'); + CompareTree(TRttiExpNode(ATreeA).Left,TRttiExpNode(ATreeB).Left); + CompareTree(TRttiExpNode(ATreeA).Right,TRttiExpNode(ATreeB).Right); + end else if ATreeA.InheritsFrom(TRttiExpConcreteNodeItem) then begin + if ATreeA.InheritsFrom(TRttiExpIntegerNodeItem) then begin + if TRttiExpIntegerNodeItem(ATreeA).Operation <> + TRttiExpIntegerNodeItem(ATreeB).Operation + then + raise Exception.Create('Operation not equal'); + + if TRttiExpIntegerNodeItem(ATreeA).ComparedValue <> + TRttiExpIntegerNodeItem(ATreeB).ComparedValue + then + raise Exception.Create('Value not equal'); + end else if ATreeA.InheritsFrom(TRttiExpStringNodeItem) then begin + if TRttiExpStringNodeItem(ATreeA).Operation <> + TRttiExpStringNodeItem(ATreeB).Operation + then + raise Exception.Create('Operation not equal'); + + if ATreeA.InheritsFrom(TRttiExpAnsiStringNodeItem) then begin + if TRttiExpAnsiStringNodeItem(ATreeA).ComparedValue <> + TRttiExpAnsiStringNodeItem(ATreeB).ComparedValue + then + raise Exception.Create('Value not equal'); + end else if ATreeA.InheritsFrom(TRttiExpWideStringNodeItem) then begin + if TRttiExpWideStringNodeItem(ATreeA).ComparedValue <> + TRttiExpWideStringNodeItem(ATreeB).ComparedValue + then + raise Exception.Create('Value not equal'); + end + end; + + end; + end; +end; + +procedure TRttiFilterCreator_Test.AddContion(); +const VAL_1 : Integer = 1210; VAL_2 : Integer = 1076; VAL_3 : Integer = 176; + VAL_4 : Integer = -176; +var + x : TRttiFilterCreator; + xin : TRttiExpIntegerNodeItem; + xn : TRttiExpNode; +begin + x := TRttiFilterCreator.Create(TClass_A); + try + x.AddCondition('IntProp',nfoGreater,VAL_1,fcOr); + CheckNotNull(x.Root,'Root'); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + CheckNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcOr ), 'Root.Connector'); + + x.AddCondition('IntProp',nfoLesser,VAL_2,fcAnd); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + CheckNotNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcAnd ), 'Root.Connector'); + CheckIs(x.Root.Right,TRttiExpIntegerNodeItem,'Root.Right'); + xin := x.Root.Right as TRttiExpIntegerNodeItem; + CheckEquals(VAL_2,xin.ComparedValue); + Check( ( xin.Operation = nfoLesser ), 'Operation'); + + x.AddCondition('IntProp',nfoEqual,VAL_3,fcOr); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + CheckNotNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcAnd ), 'Root.Connector'); + CheckIs(x.Root.Right,TRttiExpNode,'Root.Right'); + xn := x.Root.Right as TRttiExpNode; + CheckNotNull(xn.Left,'Root.Right.Left'); + CheckIs(xn.Left,TRttiExpIntegerNodeItem); + xin := xn.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_2,xin.ComparedValue); + Check( ( xin.Operation = nfoLesser ), 'Operation'); + + CheckIs(xn.Right,TRttiExpIntegerNodeItem,'xn.Right'); + xin := xn.Right as TRttiExpIntegerNodeItem; + CheckEquals(VAL_3,xin.ComparedValue); + Check( ( xin.Operation = nfoEqual ), 'Operation'); + + x.AddCondition('IntProp',nfoEqual,VAL_4,fcAnd); + PrintTree(x.Root,@Display,2); + finally + x.Free(); + end; +end; + +procedure TRttiFilterCreator_Test.BeginEnd_Group(); +const VAL_1 : Integer = 1210; VAL_2 : Integer = 1076; VAL_3 : Integer = 176; + VAL_4 : Integer = -176; +var + x : TRttiFilterCreator; + xin : TRttiExpIntegerNodeItem; + xn : TRttiExpNode; +begin + x := TRttiFilterCreator.Create(TClass_A); + try + x.AddCondition('IntProp',nfoGreater,VAL_1,fcOr); + CheckNotNull(x.Root,'Root'); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + CheckNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcOr ), 'Root.Connector'); + + x.BeginGroup(fcOr); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + + CheckNotNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcOr ), 'Root.Connector'); + CheckIs(x.Root.Right,TRttiExpNode,'Root.Right'); + xn := x.Root.Right as TRttiExpNode; + CheckNull(xn.Left); + CheckNull(xn.Right); + + x.AddCondition('IntProp',nfoLesser,VAL_2,fcAnd); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + + CheckNotNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcOr ), 'Root.Connector'); + CheckIs(x.Root.Right,TRttiExpNode,'Root.Right'); + xn := x.Root.Right as TRttiExpNode; + CheckNotNull(xn.Left,'xn.Left'); + CheckNull(xn.Right,'xn.Right'); + Check( ( xn.Connector = fcAnd ), 'xn.Connector'); + CheckIs(xn.Left,TRttiExpIntegerNodeItem,'xn.Left'); + xin := xn.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_2,xin.ComparedValue); + Check( ( xin.Operation = nfoLesser ), 'Operation'); + + x.AddCondition('IntProp',nfoEqual,VAL_3,fcAnd); + CheckNotNull(x.Root.Left,'Root.Left'); + CheckIs(x.Root.Left,TRttiExpIntegerNodeItem,'Root.Left'); + xin := x.Root.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_1,xin.ComparedValue); + Check( ( xin.Operation = nfoGreater ), 'Operation'); + + CheckNotNull(x.Root.Right,'Root.Right'); + Check( ( x.Root.Connector = fcOr ), 'Root.Connector'); + CheckIs(x.Root.Right,TRttiExpNode,'Root.Right'); + xn := x.Root.Right as TRttiExpNode; + CheckNotNull(xn.Left,'xn.Left'); + CheckNotNull(xn.Right,'xn.Right'); + Check( ( xn.Connector = fcAnd ), 'xn.Connector'); + CheckIs(xn.Left,TRttiExpIntegerNodeItem,'xn.Left'); + xin := xn.Left as TRttiExpIntegerNodeItem; + CheckEquals(VAL_2,xin.ComparedValue); + Check( ( xin.Operation = nfoLesser ), 'Operation'); + + CheckIs(xn.Right,TRttiExpIntegerNodeItem,'xn.Right'); + xin := xn.Right as TRttiExpIntegerNodeItem; + CheckEquals(VAL_3,xin.ComparedValue); + Check( ( xin.Operation = nfoEqual ), 'Operation'); + + x.EndGroup(); + x.AddCondition('IntProp',nfoEqual,VAL_4,fcOr); + PrintTree(x.Root,@Display,2); + + Display(#10#13); + Display(#10#13); + x.Clear(clrFreeObjects); + x.BeginGroup(fcAnd); + x.AddCondition('IntProp',nfoLesser,VAL_1,fcAnd); + x.BeginGroup(fcOr); + x.AddCondition('IntProp',nfoEqual,VAL_2,fcAnd); + x.AddCondition('IntProp',nfoEqual,VAL_3,fcAnd); + x.EndGroup(); + x.AddCondition('IntProp',nfoEqual,VAL_2,fcOr); + x.EndGroup(); + x.AddCondition('IntProp',nfoGreater,VAL_4,fcAnd); + PrintTree(x.Root,@Display,2); + finally + x.Free(); + end; +end; + + +{ TRttiExpAnsiStringNodeItem_Test } + +procedure TRttiExpAnsiStringNodeItem_Test.Create_Test(); +var + x : TRttiExpAnsiStringNodeItem; +begin + x := nil; + try + try + x := TRttiExpAnsiStringNodeItem.Create(GetPropInfo(TClass_A,'IntProp'),sfoEqualCaseInsensitive,'Azerty'); + Check(False); + except + on e : EAssertionFailedError do + raise; + on e : ERttiFilterException do begin + // nothing! + end; + end; + finally + x.Free(); + end; +end; + +procedure TRttiExpAnsiStringNodeItem_Test.Evaluate_EqualCaseSensitive(); +const VAL_1 = 'AzertY'; +var + x : TRttiExpAnsiStringNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpAnsiStringNodeItem.Create(GetPropInfo(t,'StrProp'),sfoEqualCaseSensitive,VAL_1); + + t.StrProp := 'aaadddd'; + Check( x.Evaluate(t) = False ,'False'); + + t.StrProp := UpperCase(VAL_1); + Check( x.Evaluate(t) = False ,'False'); + + t.StrProp := LowerCase(VAL_1); + Check( x.Evaluate(t) = False ,'False'); + + t.StrProp := VAL_1; + Check( x.Evaluate(t) = True, 'True' ); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpAnsiStringNodeItem_Test.Evaluate_EqualCaseInsensitive(); +const VAL_1 = 'AzertY'; +var + x : TRttiExpAnsiStringNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpAnsiStringNodeItem.Create(GetPropInfo(t,'StrProp'),sfoEqualCaseInsensitive,VAL_1); + + t.StrProp := 'aaadddd'; + Check( x.Evaluate(t) = False ,'False'); + + t.StrProp := UpperCase(VAL_1); + Check( x.Evaluate(t) = True ,'True'); + + t.StrProp := LowerCase(VAL_1); + Check( x.Evaluate(t) = True ,'True'); + + t.StrProp := VAL_1; + Check( x.Evaluate(t) = True, 'True' ); + finally + x.Free(); + t.Free(); + end; +end; + +{ TRttiExpwWideStringNodeItem_Test } + +procedure TRttiExpwWideStringNodeItem_Test.Create_Test(); +var + x : TRttiExpWideStringNodeItem; +begin + x := nil; + try + try + x := TRttiExpWideStringNodeItem.Create(GetPropInfo(TClass_A,'IntProp'),sfoEqualCaseInsensitive,'Azerty'); + Check(False); + except + on e : EAssertionFailedError do + raise; + on e : ERttiFilterException do begin + // nothing! + end; + end; + finally + x.Free(); + end; +end; + +procedure TRttiExpwWideStringNodeItem_Test.Evaluate_EqualCaseSensitive(); +const VAL_1 = 'AzertY'; +var + x : TRttiExpWideStringNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpWideStringNodeItem.Create(GetPropInfo(t,'WideStrProp'),sfoEqualCaseSensitive,VAL_1); + + t.WideStrProp := 'aaadddd'; + Check( x.Evaluate(t) = False ,'False'); + + t.WideStrProp := UpperCase(VAL_1); + Check( x.Evaluate(t) = False ,'False'); + + t.WideStrProp := LowerCase(VAL_1); + Check( x.Evaluate(t) = False ,'False'); + + t.WideStrProp := VAL_1; + Check( x.Evaluate(t) = True, 'True' ); + finally + x.Free(); + t.Free(); + end; +end; + +procedure TRttiExpwWideStringNodeItem_Test.Evaluate_EqualCaseInsensitive(); +const VAL_1 = 'AzertY'; +var + x : TRttiExpWideStringNodeItem; + t : TClass_A; +begin + x := nil; + t := TClass_A.Create(); + try + x := TRttiExpWideStringNodeItem.Create(GetPropInfo(t,'WideStrProp'),sfoEqualCaseInsensitive,VAL_1); + + t.WideStrProp := 'aaadddd'; + Check( x.Evaluate(t) = False ,'False'); + + t.WideStrProp := UpperCase(VAL_1); + Check( x.Evaluate(t) = True ,'True'); + + t.WideStrProp := LowerCase(VAL_1); + Check( x.Evaluate(t) = True ,'True'); + + t.WideStrProp := VAL_1; + Check( x.Evaluate(t) = True, 'True' ); + finally + x.Free(); + t.Free(); + end; +end; + + +{ TRttiParser_Test } + +procedure TRttiParser_Test.SimpleOperators(); +const VAL_1 = 'inoussa'; +var + x : TRttiFilterCreator; + sN : TRttiExpAnsiStringNodeItem; +begin + x := TRttiFilterCreator.Create(TClass_A); + try + ParseFilter(Format('StrProp = %s',[QuotedStr(VAL_1)]),x); + CheckNotNull(x.Root,'Root <> nil'); + CheckIs(x.Root.Left,TRttiExpAnsiStringNodeItem); + sN := x.Root.Left as TRttiExpAnsiStringNodeItem; + CheckEquals('StrProp',sN.PropInfo^.Name); + CheckEquals(VAL_1,sN.ComparedValue); + finally + x.Free(); + end; +end; + +procedure TRttiParser_Test.BeginEnd_Group(); +const VAL_1 : Integer = 1210; VAL_2 : Integer = 1076; VAL_3 : Integer = 176; + VAL_4 : Integer = -176; + VAL_S = 'inoussa'; +var + x, y : TRttiFilterCreator; + xin : TRttiExpIntegerNodeItem; + xn : TRttiExpNode; + sfltr : string; +begin + y := nil; + x := TRttiFilterCreator.Create(TClass_A); + try + sfltr := Format('IntProp > %d or ( IntProp < %d and StrProp = %s ) or IntProp = %d',[VAL_1,VAL_2,QuotedStr(VAL_S),VAL_4]); + ParseFilter(sfltr,x); + PrintTree(x.Root,@Display,2); + y := TRttiFilterCreator.Create(TClass_A); + y.AddCondition('IntProp',nfoGreater,VAL_1,fcOr); + y.BeginGroup(fcOr); + y.AddCondition('IntProp',nfoLesser,VAL_2,fcAnd); + y.AddCondition('StrProp',sfoEqualCaseInsensitive,VAL_S,fcAnd); + y.EndGroup(); + y.AddCondition('IntProp',nfoEqual,VAL_4,fcOr); + + CompareTree(x.Root,y.Root); + finally + x.Free(); + end; +end; + + +Initialization + RegisterTests( + [ TRttiExpIntegerNodeItem_Test, + TRttiExpAnsiStringNodeItem_Test, + TRttiExpwWideStringNodeItem_Test, + TRttiExpNode_Test,TRttiFilterCreator_Test, + + TRttiParser_Test + ] + ); + +end.