From 1069954eba06240322a174cbf944ee7eef839a23 Mon Sep 17 00:00:00 2001 From: inoussa Date: Sun, 19 Aug 2007 21:04:16 +0000 Subject: [PATCH] Record support : - Field may be hidden by calling SetFieldSerializationVisibility() - Field may be mapped to XML Attribute by calling RegisterAttributeProperty() Some methods and routines have been marked "inline". By default the "inline" modifier is not enable. To enable it uncomment the "//{$DEFINE USE_INLINE}" line in wst_global.inc. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@244 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- wst/trunk/base_binary_formatter.pas | 51 +-- wst/trunk/base_service_intf.pas | 326 +++++++++------- wst/trunk/base_soap_formatter.pas | 52 +-- wst/trunk/base_xmlrpc_formatter.pas | 52 +-- wst/trunk/binary_formatter.pas | 4 +- wst/trunk/binary_streamer.pas | 11 +- wst/trunk/imp_utils.pas | 6 +- wst/trunk/record_rtti.pas | 30 ++ wst/trunk/samples/http_server/http_server.lpi | 21 +- .../user_client_console.lpi | 11 +- wst/trunk/server_binary_formatter.pas | 16 +- wst/trunk/service_intf.pas | 12 +- wst/trunk/tests/test_suite/test_utilities.pas | 11 + .../tests/test_suite/testformatter_unit.pas | 144 ++++++- wst/trunk/tests/test_suite/wst_test_suite.lpi | 352 +++++++++++------- wst/trunk/wst_global.inc | 1 + 16 files changed, 720 insertions(+), 380 deletions(-) diff --git a/wst/trunk/base_binary_formatter.pas b/wst/trunk/base_binary_formatter.pas index 7b2ae8a77..31b600c16 100644 --- a/wst/trunk/base_binary_formatter.pas +++ b/wst/trunk/base_binary_formatter.pas @@ -16,7 +16,7 @@ interface uses Classes, SysUtils, Contnrs, TypInfo, - base_service_intf, binary_streamer; + base_service_intf, binary_streamer, wst_types; {$DEFINE wst_binary_header} @@ -30,8 +30,11 @@ const type EBinaryFormatterException = class(EServiceException) - End; + end; + EBinaryException = class(EBaseRemoteException) + end; + TDataName = AnsiString; TDataType = ( dtInt8U, dtInt8S, @@ -178,94 +181,94 @@ type protected function HasScope():Boolean; procedure CheckScope(); - procedure ClearStack(); - procedure PushStack(AScopeObject : PDataBuffer;Const AScopeType : TScopeType = stObject); - function StackTop():TStackItem; - function PopStack():TStackItem; - function GetRootData() : PDataBuffer; + procedure ClearStack();{$IFDEF USE_INLINE}inline;{$ENDIF} + procedure PushStack(AScopeObject : PDataBuffer;Const AScopeType : TScopeType = stObject);{$IFDEF USE_INLINE}inline;{$ENDIF} + function StackTop():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PopStack():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetRootData() : PDataBuffer;{$IFDEF USE_INLINE}inline;{$ENDIF} protected procedure PutFloat( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TFloat_Extended_10 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutInt( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TInt64S - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutStr( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : String - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutEnum( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TEnumData - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutBool( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Boolean - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutInt64( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Int64 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutObj( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TObject - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutRecord( const AName : string; const ATypeInfo : PTypeInfo; const AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} - function GetDataBuffer(var AName : String):PDataBuffer; + function GetDataBuffer(var AName : String):PDataBuffer;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetEnum( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TEnumData - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetBool( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Boolean - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetFloat( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TFloat_Extended_10 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetInt( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TInt64S - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetInt64( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Int64 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetStr( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : String - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetObj( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TObject - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetRecord( const ATypeInfo : PTypeInfo; var AName : String; var AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} public constructor Create();override; destructor Destroy();override; diff --git a/wst/trunk/base_service_intf.pas b/wst/trunk/base_service_intf.pas index 0e12b525f..933b35804 100644 --- a/wst/trunk/base_service_intf.pas +++ b/wst/trunk/base_service_intf.pas @@ -1097,7 +1097,7 @@ type FPool : TIntfPool; FTimeOut: PtrUInt; private - procedure PreparePool(); + procedure PreparePool();{$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetPooled(const AValue: Boolean); procedure SetPoolMax(const AValue: PtrInt); procedure SetPoolMin(const AValue: PtrInt); @@ -1138,7 +1138,7 @@ type FExternalNames : TStrings; FInternalNames : TStrings; private - procedure CreateInternalObjects(); + procedure CreateInternalObjects();{$IFDEF USE_INLINE}inline;{$ENDIF} public constructor Create( ANameSpace : string; @@ -1146,12 +1146,12 @@ type Const ADeclaredName : string = '' ); destructor Destroy();override; - function AddPascalSynonym(const ASynonym : string):TTypeRegistryItem;//inline; - function IsSynonym(const APascalTypeName : string):Boolean;//inline; + function AddPascalSynonym(const ASynonym : string):TTypeRegistryItem; + function IsSynonym(const APascalTypeName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); - function GetExternalPropertyName(const APropName : string) : string; - function GetInternalPropertyName(const AExtPropName : string) : string; + function GetExternalPropertyName(const APropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetInternalPropertyName(const AExtPropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure RegisterObject(const APropName : string; const AObject : TObject); function GetObject(const APropName : string) : TObject; @@ -1167,8 +1167,8 @@ type TTypeRegistry = class Private FList : TObjectList; - function GetCount: Integer; - function GetItemByIndex(Index: Integer): TTypeRegistryItem; + function GetCount: Integer;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetItemByIndex(Index: Integer): TTypeRegistryItem;{$IFDEF USE_INLINE}inline;{$ENDIF} function GetItemByTypeInfo(Index: PTypeInfo): TTypeRegistryItem; Public constructor Create(); @@ -1222,8 +1222,18 @@ const PROP_LIST_DELIMITER = ';'; FIELDS_STRING = '__FIELDS__'; - function GetTypeRegistry():TTypeRegistry; + function GetTypeRegistry():TTypeRegistry;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure RegisterStdTypes(); + procedure RegisterAttributeProperty( + const ATypeInfo : PTypeInfo; // must be tkClass or tkRecord + const AProperty : shortstring + ); + procedure SetFieldSerializationVisibility( + const ATypeInfo : PTypeInfo; // must be tkRecord + const AField : shortstring; + const AVisibility : Boolean + ); + function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType; @@ -1336,6 +1346,62 @@ begin r.Register(sXSD_NS,TypeInfo(TComplexBooleanContentRemotable),'boolean').AddPascalSynonym('TComplexBooleanContentRemotable'); end; +procedure SetFieldSerializationVisibility( + const ATypeInfo : PTypeInfo; // must be tkRecord + const AField : shortstring; + const AVisibility : Boolean +); +var + recordData : TRecordRttiDataObject; +begin + if Assigned(ATypeInfo) and ( ATypeInfo^.Kind = tkRecord ) and + ( not IsStrEmpty(AField) ) + then begin + recordData := GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetObject(FIELDS_STRING) as TRecordRttiDataObject; + if Assigned(recordData) then begin + recordData.GetField(AField)^.Visible := AVisibility; + end else begin + raise EServiceConfigException.CreateFmt('Record extended RTTI informations not found in type registry : "%s".',[ATypeInfo^.Name]); + end; + end else begin + raise EServiceConfigException.Create('Invalid parameters.'); + end; +end; + +procedure RegisterAttributeProperty( + const ATypeInfo : PTypeInfo; + const AProperty : shortstring +); +var + ok : Boolean; + recordData : TRecordRttiDataObject; +begin + ok := False; + if Assigned(ATypeInfo) and + ( not IsStrEmpty(AProperty) ) + then begin + case ATypeInfo^.Kind of + tkClass : + begin + if GetTypeData(ATypeInfo)^.ClassType.InheritsFrom(TAbstractComplexRemotable) then begin + TAbstractComplexRemotableClass(GetTypeData(ATypeInfo)^.ClassType).RegisterAttributeProperty(AProperty); + ok := True; + end; + end; + tkRecord : + begin + recordData := GetTypeRegistry().ItemByTypeInfo[ATypeInfo].GetObject(FIELDS_STRING) as TRecordRttiDataObject; + if Assigned(recordData) then begin + recordData.GetField(AProperty)^.IsAttribute := True; + ok := True; + end; + end; + end; + end; + if not ok then + raise EServiceConfigException.Create('Invalid parameters.'); +end; + {$IFDEF FPC} function IsStoredPropClass(AClass : TClass;PropInfo : PPropInfo) : TPropStoreType; begin @@ -2392,7 +2458,7 @@ begin inherited Destroy(); end; -function TTypeRegistryItem.AddPascalSynonym(const ASynonym: string):TTypeRegistryItem; //inline; +function TTypeRegistryItem.AddPascalSynonym(const ASynonym: string):TTypeRegistryItem; begin Result := Self; if AnsiSameText(ASynonym,DataType^.Name) then @@ -2405,7 +2471,7 @@ begin FSynonymTable.Add(AnsiLowerCase(ASynonym)); end; -function TTypeRegistryItem.IsSynonym(const APascalTypeName: string): Boolean;//inline; +function TTypeRegistryItem.IsSynonym(const APascalTypeName: string): Boolean; begin Result := AnsiSameText(APascalTypeName,DataType^.Name); if ( not Result ) and Assigned(FSynonymTable) then @@ -4614,64 +4680,66 @@ begin ss := AStore.GetSerializationStyle(); for i := 0 to Pred(typData^.FieldCount) do begin p := @(typData^.Fields[i]); - pt := p^.TypeInfo^;//{$IFNDEF FPC}^{$ENDIF}; - {if IsAttributeProperty(p^.Name) then begin - if ( ss <> ssAttibuteSerialization ) then - ss := ssAttibuteSerialization; - end else begin - if ( ss <> ssNodeSerialization ) then - ss := ssNodeSerialization; - end; - if ( ss <> AStore.GetSerializationStyle() ) then - AStore.SetSerializationStyle(ss);} - AStore.SetSerializationStyle(ssNodeSerialization); - prpName := typRegItem.GetExternalPropertyName(p^.Name); - recFieldAddress := recStart; - Inc(recFieldAddress,p^.Offset); - case pt^.Kind of - tkInt64 : AStore.Put(prpName,pt,PInt64(recFieldAddress)^); - {$IFDEF HAS_QWORD} - tkQWord : AStore.Put(prpName,pt,PQWord(recFieldAddress)^); - {$ENDIF} - tkLString{$IFDEF FPC},tkAString{$ENDIF} : AStore.Put(prpName,pt,PString(recFieldAddress)^); - tkClass : AStore.Put(prpName,pt,PObject(recFieldAddress)^); - tkRecord : AStore.Put(prpName,pt,Pointer(recFieldAddress)^); - {$IFDEF FPC} - tkBool : AStore.Put(prpName,pt,PBoolean(recFieldAddress)^); - {$ENDIF} - tkEnumeration,tkInteger : - begin - {$IFNDEF FPC} - if ( pt^.Kind = tkEnumeration ) and - ( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) ) - then begin - AStore.Put(prpName,pt,PBoolean(recFieldAddress)^); - end else begin + if p^.Visible then begin + pt := p^.TypeInfo^; + if p^.IsAttribute then begin + if ( ss <> ssAttibuteSerialization ) then + ss := ssAttibuteSerialization; + end else begin + if ( ss <> ssNodeSerialization ) then + ss := ssNodeSerialization; + end; + if ( ss <> AStore.GetSerializationStyle() ) then + AStore.SetSerializationStyle(ss); + AStore.SetSerializationStyle(ss); + prpName := typRegItem.GetExternalPropertyName(p^.Name); + recFieldAddress := recStart; + Inc(recFieldAddress,p^.Offset); + case pt^.Kind of + tkInt64 : AStore.Put(prpName,pt,PInt64(recFieldAddress)^); + {$IFDEF HAS_QWORD} + tkQWord : AStore.Put(prpName,pt,PQWord(recFieldAddress)^); {$ENDIF} - case GetTypeData(pt)^.OrdType of - otSByte : AStore.Put(prpName,pt,PShortInt(recFieldAddress)^); - otUByte : AStore.Put(prpName,pt,PByte(recFieldAddress)^); - otSWord : AStore.Put(prpName,pt,PSmallInt(recFieldAddress)^); - otUWord : AStore.Put(prpName,pt,PWord(recFieldAddress)^); - otSLong : AStore.Put(prpName,pt,PLongint(recFieldAddress)^); - otULong : AStore.Put(prpName,pt,PLongWord(recFieldAddress)^); + tkLString{$IFDEF FPC},tkAString{$ENDIF} : AStore.Put(prpName,pt,PString(recFieldAddress)^); + tkClass : AStore.Put(prpName,pt,PObject(recFieldAddress)^); + tkRecord : AStore.Put(prpName,pt,Pointer(recFieldAddress)^); + {$IFDEF FPC} + tkBool : AStore.Put(prpName,pt,PBoolean(recFieldAddress)^); + {$ENDIF} + tkEnumeration,tkInteger : + begin + {$IFNDEF FPC} + if ( pt^.Kind = tkEnumeration ) and + ( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) ) + then begin + AStore.Put(prpName,pt,PBoolean(recFieldAddress)^); + end else begin + {$ENDIF} + case GetTypeData(pt)^.OrdType of + otSByte : AStore.Put(prpName,pt,PShortInt(recFieldAddress)^); + otUByte : AStore.Put(prpName,pt,PByte(recFieldAddress)^); + otSWord : AStore.Put(prpName,pt,PSmallInt(recFieldAddress)^); + otUWord : AStore.Put(prpName,pt,PWord(recFieldAddress)^); + otSLong : AStore.Put(prpName,pt,PLongint(recFieldAddress)^); + otULong : AStore.Put(prpName,pt,PLongWord(recFieldAddress)^); + end; + {$IFNDEF FPC} end; - {$IFNDEF FPC} + {$ENDIF} end; - {$ENDIF} - end; - tkFloat : - begin - case GetTypeData(pt)^.FloatType of - ftSingle : AStore.Put(prpName,pt,PSingle(recFieldAddress)^); - ftDouble : AStore.Put(prpName,pt,PDouble(recFieldAddress)^); - ftExtended : AStore.Put(prpName,pt,PExtended(recFieldAddress)^); - ftCurr : AStore.Put(prpName,pt,PCurrency(recFieldAddress)^); -{$IFDEF HAS_COMP} - ftComp : AStore.Put(prpName,pt,PComp(recFieldAddress)^); -{$ENDIF} + tkFloat : + begin + case GetTypeData(pt)^.FloatType of + ftSingle : AStore.Put(prpName,pt,PSingle(recFieldAddress)^); + ftDouble : AStore.Put(prpName,pt,PDouble(recFieldAddress)^); + ftExtended : AStore.Put(prpName,pt,PExtended(recFieldAddress)^); + ftCurr : AStore.Put(prpName,pt,PCurrency(recFieldAddress)^); + {$IFDEF HAS_COMP} + ftComp : AStore.Put(prpName,pt,PComp(recFieldAddress)^); + {$ENDIF} + end; end; - end; + end; end; end; end; @@ -4694,7 +4762,6 @@ var pt : PTypeInfo; propName : String; p : PRecordFieldInfo; - persistType : TPropStoreType; oldSS,ss : TSerializationStyle; typRegItem : TTypeRegistryItem; typDataObj : TObject; @@ -4718,70 +4785,71 @@ begin recStart := PByte(ARecord); for i := 0 to Pred(typData^.FieldCount) do begin p := @(typData^.Fields[i]); - persistType := pstOptional;// IsStoredPropClass(objTypeData^.ClassType,p); - pt := p^.TypeInfo^;//{$IFNDEF FPC}^{$ENDIF}; - propName := typRegItem.GetExternalPropertyName(p^.Name); - {if IsAttributeProperty(p^.Name) then begin - ss := ssAttibuteSerialization; - end else begin - ss := ssNodeSerialization; - end; - if ( ss <> AStore.GetSerializationStyle() ) then - AStore.SetSerializationStyle(ss);} - AStore.SetSerializationStyle(ssNodeSerialization); - recFieldAddress := recStart; - Inc(recFieldAddress,p^.Offset); - try - Case pt^.Kind Of - tkInt64 : AStore.Get(pt,propName,PInt64(recFieldAddress)^); - {$IFDEF HAS_QWORD} - tkQWord : AStore.Get(pt,propName,PQWord(recFieldAddress)^); - {$ENDIF} - tkLString{$IFDEF FPC}, tkAString{$ENDIF} : AStore.Get(pt,propName,PString(recFieldAddress)^); - {$IFDEF FPC} - tkBool : AStore.Get(pt,propName,PBoolean(recFieldAddress)^); - {$ENDIF} - tkClass : AStore.Get(pt,propName,PObject(recFieldAddress)^); - tkRecord : AStore.Get(pt,propName,Pointer(recFieldAddress)^); - tkEnumeration,tkInteger : - Begin - {$IFNDEF FPC} - if ( pt^.Kind = tkEnumeration ) and - ( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) ) - then begin - AStore.Get(pt,propName,PBoolean(recFieldAddress)^); - end else begin - {$ENDIF} - case GetTypeData(pt)^.OrdType Of - otSByte : AStore.Get(pt,propName,PShortInt(recFieldAddress)^); - otUByte : AStore.Get(pt,propName,PByte(recFieldAddress)^); - otSWord : AStore.Get(pt,propName,PSmallInt(recFieldAddress)^); - otUWord : AStore.Get(pt,propName,PWord(recFieldAddress)^); - otSLong : AStore.Get(pt,propName,PLongint(recFieldAddress)^); - otULong : AStore.Get(pt,propName,PLongWord(recFieldAddress)^); - end; - {$IFNDEF FPC} - end; - {$ENDIF} - End; - tkFloat : - begin - case GetTypeData(pt)^.FloatType of - ftSingle : AStore.Get(pt,propName,PSingle(recFieldAddress)^); - ftDouble : AStore.Get(pt,propName,PDouble(recFieldAddress)^); - ftExtended : AStore.Get(pt,propName,PExtended(recFieldAddress)^); - ftCurr : AStore.Get(pt,propName,PCurrency(recFieldAddress)^); - {$IFDEF HAS_COMP} - ftComp : AStore.Get(pt,propName,PComp(recFieldAddress)^); - {$ENDIF} - end; - end; - End; - except - on E : EServiceException do begin - if ( persistType = pstAlways ) then - raise; + if p^.Visible then begin + pt := p^.TypeInfo^; + propName := typRegItem.GetExternalPropertyName(p^.Name); + if p^.IsAttribute then begin + ss := ssAttibuteSerialization; + end else begin + ss := ssNodeSerialization; end; + if ( ss <> AStore.GetSerializationStyle() ) then + AStore.SetSerializationStyle(ss); + AStore.SetSerializationStyle(ss); + recFieldAddress := recStart; + Inc(recFieldAddress,p^.Offset); + //try + Case pt^.Kind Of + tkInt64 : AStore.Get(pt,propName,PInt64(recFieldAddress)^); + {$IFDEF HAS_QWORD} + tkQWord : AStore.Get(pt,propName,PQWord(recFieldAddress)^); + {$ENDIF} + tkLString{$IFDEF FPC}, tkAString{$ENDIF} : AStore.Get(pt,propName,PString(recFieldAddress)^); + {$IFDEF FPC} + tkBool : AStore.Get(pt,propName,PBoolean(recFieldAddress)^); + {$ENDIF} + tkClass : AStore.Get(pt,propName,PObject(recFieldAddress)^); + tkRecord : AStore.Get(pt,propName,Pointer(recFieldAddress)^); + tkEnumeration,tkInteger : + Begin + {$IFNDEF FPC} + if ( pt^.Kind = tkEnumeration ) and + ( GetTypeData(pt)^.BaseType^ = TypeInfo(Boolean) ) + then begin + AStore.Get(pt,propName,PBoolean(recFieldAddress)^); + end else begin + {$ENDIF} + case GetTypeData(pt)^.OrdType Of + otSByte : AStore.Get(pt,propName,PShortInt(recFieldAddress)^); + otUByte : AStore.Get(pt,propName,PByte(recFieldAddress)^); + otSWord : AStore.Get(pt,propName,PSmallInt(recFieldAddress)^); + otUWord : AStore.Get(pt,propName,PWord(recFieldAddress)^); + otSLong : AStore.Get(pt,propName,PLongint(recFieldAddress)^); + otULong : AStore.Get(pt,propName,PLongWord(recFieldAddress)^); + end; + {$IFNDEF FPC} + end; + {$ENDIF} + End; + tkFloat : + begin + case GetTypeData(pt)^.FloatType of + ftSingle : AStore.Get(pt,propName,PSingle(recFieldAddress)^); + ftDouble : AStore.Get(pt,propName,PDouble(recFieldAddress)^); + ftExtended : AStore.Get(pt,propName,PExtended(recFieldAddress)^); + ftCurr : AStore.Get(pt,propName,PCurrency(recFieldAddress)^); + {$IFDEF HAS_COMP} + ftComp : AStore.Get(pt,propName,PComp(recFieldAddress)^); + {$ENDIF} + end; + end; + End; + {except + on E : EServiceException do begin + if ( persistType = pstAlways ) then + raise; + end; + end;} end; end; end; diff --git a/wst/trunk/base_soap_formatter.pas b/wst/trunk/base_soap_formatter.pas index 255e3a7d0..403919aba 100644 --- a/wst/trunk/base_soap_formatter.pas +++ b/wst/trunk/base_soap_formatter.pas @@ -139,12 +139,12 @@ type FKeepedEncoding : TSOAPEncodingStyle; FSerializationStyle : TSerializationStyle; - procedure InternalClear(const ACreateDoc : Boolean); + procedure InternalClear(const ACreateDoc : Boolean);{$IFDEF USE_INLINE}inline;{$ENDIF} - function NextNameSpaceCounter():Integer;//inline; - function HasScope():Boolean;//inline; + function NextNameSpaceCounter():Integer;{$IFDEF USE_INLINE}inline;{$ENDIF} + function HasScope():Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF} - procedure CheckScope();//inline; + procedure CheckScope();{$IFDEF USE_INLINE}inline;{$ENDIF} function InternalPutData( Const AName : String; Const ATypeInfo : PTypeInfo; @@ -154,89 +154,89 @@ type Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TEnumIntType - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutBool( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Boolean - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutInt64( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Int64 - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutStr( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : String - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutFloat( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Extended - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutObj( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TObject - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutRecord( const AName : string; const ATypeInfo : PTypeInfo; const AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} function GetNodeValue(var AName : String):DOMString; procedure GetEnum( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TEnumIntType - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetBool( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Boolean - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} {$IFDEF FPC} procedure GetInt( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Integer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} {$ENDIF} procedure GetInt64( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Int64 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetFloat( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Extended - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetStr( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : String - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetObj( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TObject - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetRecord( const ATypeInfo : PTypeInfo; var AName : String; var AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} protected - function GetXmlDoc():TwstXMLDocument; - function PushStack(AScopeObject : TDOMNode):TStackItem;overload; + function GetXmlDoc():TwstXMLDocument;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PushStack(AScopeObject : TDOMNode):TStackItem;overload;{$IFDEF USE_INLINE}inline;{$ENDIF} function PushStack( AScopeObject : TDOMNode; const AStyle : TArrayStyle; const AItemName : string - ):TStackItem;overload; + ):TStackItem;overload;{$IFDEF USE_INLINE}inline;{$ENDIF} function FindAttributeByValueInNode( Const AAttValue : String; Const ANode : TDOMNode; @@ -252,13 +252,13 @@ type function GetNameSpaceShortName( const ANameSpace : string; const ACreateIfNotFound : Boolean - ):shortstring; + ):shortstring;{$IFDEF USE_INLINE}inline;{$ENDIF} protected function GetCurrentScope():String; function GetCurrentScopeObject():TDOMElement; - function StackTop():TStackItem; - function PopStack():TStackItem; - procedure ClearStack(); + function StackTop():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PopStack():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + procedure ClearStack();{$IFDEF USE_INLINE}inline;{$ENDIF} procedure BeginScope( Const AScopeName,ANameSpace : string; Const ANameSpaceShortName : string ; diff --git a/wst/trunk/base_xmlrpc_formatter.pas b/wst/trunk/base_xmlrpc_formatter.pas index 5339f105b..e415b4df7 100644 --- a/wst/trunk/base_xmlrpc_formatter.pas +++ b/wst/trunk/base_xmlrpc_formatter.pas @@ -150,66 +150,66 @@ type FStack : TObjectStack; FSerializationStyle: TSerializationStyle; private - procedure InternalClear(const ACreateDoc : Boolean); + procedure InternalClear(const ACreateDoc : Boolean);{$IFDEF USE_INLINE}inline;{$ENDIF} - function HasScope():Boolean;//inline; + function HasScope():Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF} - procedure CheckScope();//inline; + procedure CheckScope();{$IFDEF USE_INLINE}inline;{$ENDIF} function InternalPutData( const AName : string; const AType : TXmlRpcDataType; const AData : string - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutEnum( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TEnumIntType - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} {$IFDEF FPC} function PutBool( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Boolean - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} {$ENDIF} function PutInt64( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Int64 - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutStr( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : String - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} function PutFloat( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : Extended - ):TDOMNode; + ):TDOMNode;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutObj( Const AName : String; Const ATypeInfo : PTypeInfo; Const AData : TObject - ); + ); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure PutRecord( const AName : string; const ATypeInfo : PTypeInfo; const AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} function GetNodeValue(var AName : String):DOMString; procedure GetEnum( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TEnumIntType - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} {$IFDEF FPC} procedure GetBool( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Boolean - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetInt( Const ATypeInfo : PTypeInfo; Var AName : String; @@ -220,36 +220,36 @@ type Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Int64 - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetFloat( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : Extended - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetStr( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : String - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetObj( Const ATypeInfo : PTypeInfo; Var AName : String; Var AData : TObject - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} procedure GetRecord( const ATypeInfo : PTypeInfo; var AName : String; var AData : Pointer - ); + );{$IFDEF USE_INLINE}inline;{$ENDIF} protected - function GetXmlDoc():TXMLDocument; - function PushStack(AScopeObject : TDOMNode):TStackItem;overload; + function GetXmlDoc():TXMLDocument;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PushStack(AScopeObject : TDOMNode):TStackItem;overload;{$IFDEF USE_INLINE}inline;{$ENDIF} function PushStack( AScopeObject : TDOMNode; const AStyle : TArrayStyle; const AItemName : string - ):TStackItem;overload; - function PushStackParams(AScopeObject : TDOMNode) : TStackItem; + ):TStackItem;overload;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PushStackParams(AScopeObject : TDOMNode) : TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} function FindAttributeByValueInNode( Const AAttValue : String; Const ANode : TDOMNode; @@ -264,10 +264,10 @@ type function FindAttributeByNameInScope(Const AAttName : String):String; protected function GetCurrentScope():String; - function GetCurrentScopeObject():TDOMElement; - function StackTop():TStackItem; - function PopStack():TStackItem; - procedure ClearStack(); + function GetCurrentScopeObject():TDOMElement;{$IFDEF USE_INLINE}inline;{$ENDIF} + function StackTop():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + function PopStack():TStackItem;{$IFDEF USE_INLINE}inline;{$ENDIF} + procedure ClearStack();{$IFDEF USE_INLINE}inline;{$ENDIF} procedure BeginScope( Const AScopeName,ANameSpace : string; Const ANameSpaceShortName : string ; diff --git a/wst/trunk/binary_formatter.pas b/wst/trunk/binary_formatter.pas index 97824154b..34fbcf700 100644 --- a/wst/trunk/binary_formatter.pas +++ b/wst/trunk/binary_formatter.pas @@ -100,7 +100,7 @@ end; procedure TBinaryFormatter.BeginCallRead(ACallContext : ICallContext); Var s,nme : string; - e : EBaseRemoteException; + e : EBinaryException; begin ClearStack(); PushStack(GetRootData(),stObject); @@ -109,7 +109,7 @@ begin s := StackTop().GetByIndex(0)^.Name; If AnsiSameText(s,'Fault') Then Begin BeginObjectRead(s,nil); - e := EBaseRemoteException.Create(''); + e := EBinaryException.Create(''); Try nme := 'faultcode'; Get(TypeInfo(string),nme,s); diff --git a/wst/trunk/binary_streamer.pas b/wst/trunk/binary_streamer.pas index ea28923a3..8af1fa95b 100644 --- a/wst/trunk/binary_streamer.pas +++ b/wst/trunk/binary_streamer.pas @@ -17,10 +17,7 @@ unit binary_streamer; interface uses - Classes, SysUtils, Types; - -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} + Classes, SysUtils, Types, wst_types; Const MAX_ARRAY_LENGTH = 1024*1024; @@ -30,7 +27,7 @@ Type TInt8U = Byte; TInt8S = ShortInt; TInt16U = Word; TInt16S = SmallInt; TInt32U = LongWord; TInt32S = LongInt; - TInt64S = Int64;TInt64U = QWord; + TInt64S = Int64; TInt64U = QWord; TBoolData = Boolean; TEnumData = Int64; TStringData = AnsiString; @@ -89,8 +86,8 @@ Type function ReadCurrency():TFloat_Currency_8; End; - function CreateBinaryReader(AStream : TStream):IDataStoreReader; - function CreateBinaryWriter(AStream : TStream):IDataStore; + function CreateBinaryReader(AStream : TStream):IDataStoreReader;{$IFDEF USE_INLINE}inline;{$ENDIF} + function CreateBinaryWriter(AStream : TStream):IDataStore;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure ReverseBytes(var AData; const ALength : Integer);{$IFDEF USE_INLINE}{$IFDEF ENDIAN_BIG}inline;{$ENDIF}{$ENDIF} function Reverse_16(const AValue:Word):Word;{$IFDEF USE_INLINE}inline;{$ENDIF} diff --git a/wst/trunk/imp_utils.pas b/wst/trunk/imp_utils.pas index 3e52a7bac..518ffbfb6 100644 --- a/wst/trunk/imp_utils.pas +++ b/wst/trunk/imp_utils.pas @@ -29,8 +29,8 @@ Type TPublishedPropertyManager = class(TInterfacedObject,IPropertyManager) Private FParent : TObject; - procedure Error(Const AMsg:string);overload; - procedure Error(Const AMsg:string; Const AArgs : array of const);overload; + procedure Error(Const AMsg:string);overload;{$IFDEF USE_INLINE}inline;{$ENDIF} + procedure Error(Const AMsg:string; Const AArgs : array of const);overload;{$IFDEF USE_INLINE}inline;{$ENDIF} Protected procedure SetProperty(Const AName,AValue:string); procedure SetProperties(Const APropsStr:string); @@ -42,7 +42,7 @@ Type constructor Create(AParent : TObject); End; - function IsStrEmpty(Const AStr:String):Boolean; + function IsStrEmpty(Const AStr:String):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF} function GetToken(var ABuffer : string; const ADelimiter : string): string; function ExtractOptionName(const ACompleteName : string):string; diff --git a/wst/trunk/record_rtti.pas b/wst/trunk/record_rtti.pas index 1ae9a2c6e..e9135eb59 100644 --- a/wst/trunk/record_rtti.pas +++ b/wst/trunk/record_rtti.pas @@ -27,6 +27,8 @@ type Name : shortstring; TypeInfo : PPTypeInfo; Offset : PtrUInt; + IsAttribute : Boolean; + Visible : Boolean; end; PRecordTypeData = ^TRecordTypeData; @@ -44,6 +46,8 @@ type constructor Create(const AData : PRecordTypeData; const AFieldList : string); destructor Destroy();override; function GetRecordTypeData() : PRecordTypeData; + function FindField(const AFieldName : shortstring) : PRecordFieldInfo; + function GetField(const AFieldName : shortstring) : PRecordFieldInfo; end; function MakeRecordTypeInfo(ARawTypeInfo : PTypeInfo) : PRecordTypeData; @@ -182,6 +186,7 @@ begin fieldInfo := @(resBuffer^.Fields[(i - 1)]); fieldInfo^.TypeInfo := fld^.TypeInfo; fieldInfo^.Offset := fld^.Offset; + fieldInfo^.Visible := True; end; Result := resBuffer; end; @@ -258,6 +263,7 @@ begin Inc(Temp,sizeof(Info)); Offset := PLongint(Temp)^; fieldInfo^.Offset := Offset; + fieldInfo^.Visible := True; Inc(Temp,sizeof(Offset)); end; Result := resBuffer; @@ -306,6 +312,30 @@ begin Result := PRecordTypeData(Data); end; +function TRecordRttiDataObject.FindField(const AFieldName : shortstring) : PRecordFieldInfo; +var + i : PtrInt; + locData : PRecordTypeData; + locField : shortstring; +begin + Result := nil; + locData := PRecordTypeData(Data); + locField := UpperCase(AFieldName); + for i := 0 to Pred(locData^.FieldCount) do begin + if ( locField = UpperCase(locData^.Fields[i].Name) ) then begin + Result := @(locData^.Fields[i]); + Break; + end; + end; +end; + +function TRecordRttiDataObject.GetField(const AFieldName : shortstring) : PRecordFieldInfo; +begin + Result := FindField(AFieldName); + if ( Result = nil ) then + raise Exception.CreateFmt('"%s" is not a field of "%s".',[AFieldName,GetRecordTypeData()^.Name]); +end; + initialization {$IFDEF WST_RECORD_RTTI} RawTypeInfoList := TList.Create(); diff --git a/wst/trunk/samples/http_server/http_server.lpi b/wst/trunk/samples/http_server/http_server.lpi index 7e16a90bc..cac463067 100644 --- a/wst/trunk/samples/http_server/http_server.lpi +++ b/wst/trunk/samples/http_server/http_server.lpi @@ -12,7 +12,7 @@ - + @@ -35,7 +35,7 @@ - + @@ -421,8 +421,8 @@ - - + + @@ -555,8 +555,19 @@ + + + + + + - + + + + + + diff --git a/wst/trunk/samples/user_client_console/user_client_console.lpi b/wst/trunk/samples/user_client_console/user_client_console.lpi index 418c512d7..9f085688f 100644 --- a/wst/trunk/samples/user_client_console/user_client_console.lpi +++ b/wst/trunk/samples/user_client_console/user_client_console.lpi @@ -355,16 +355,7 @@ - - - - - - - - - - + diff --git a/wst/trunk/server_binary_formatter.pas b/wst/trunk/server_binary_formatter.pas index d95b85a8b..165ae4fc5 100644 --- a/wst/trunk/server_binary_formatter.pas +++ b/wst/trunk/server_binary_formatter.pas @@ -20,18 +20,12 @@ uses base_service_intf, server_service_intf, base_binary_formatter; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - + const sBINARY_CONTENT_TYPE = 'binary'; sPROTOCOL_NAME = sBINARY_CONTENT_TYPE; - procedure Server_service_RegisterBinaryFormat(); - -implementation - -Type +type { TBinaryFormatter } @@ -51,6 +45,12 @@ Type ); procedure EndExceptionList(); End; + + procedure Server_service_RegisterBinaryFormat(); + +implementation + +Type { TBinaryFormatterFactory } diff --git a/wst/trunk/service_intf.pas b/wst/trunk/service_intf.pas index 83fb99cb9..031ac7572 100644 --- a/wst/trunk/service_intf.pas +++ b/wst/trunk/service_intf.pas @@ -85,10 +85,10 @@ Type private procedure LoadProperties(); protected - function GetTarget():String; - function GetSerializer() : IFormatterClient; - function GetCallHandler() : ICallMaker; - function GetTransport() : ITransport; + function GetTarget():String;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetSerializer() : IFormatterClient;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetCallHandler() : ICallMaker;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetTransport() : ITransport;{$IFDEF USE_INLINE}inline;{$ENDIF} procedure MakeCall(); class function GetServiceType() : PTypeInfo;virtual;abstract; @@ -147,8 +147,8 @@ Type ); End; - function GetFormaterRegistry():IFormaterQueryRegistry; - function GetTransportRegistry():ITransportRegistry; + function GetFormaterRegistry():IFormaterQueryRegistry;{$IFDEF USE_INLINE}inline;{$ENDIF} + function GetTransportRegistry():ITransportRegistry;{$IFDEF USE_INLINE}inline;{$ENDIF} implementation uses imp_utils, metadata_repository; diff --git a/wst/trunk/tests/test_suite/test_utilities.pas b/wst/trunk/tests/test_suite/test_utilities.pas index e4474bdf2..ac969aaad 100644 --- a/wst/trunk/tests/test_suite/test_utilities.pas +++ b/wst/trunk/tests/test_suite/test_utilities.pas @@ -1,3 +1,14 @@ +{ This file is part of the Web Service Toolkit + Copyright (c) 2006, 2007 by Inoussa OUEDRAOGO + + This file is provide under modified LGPL licence + ( the files COPYING.modifiedLGPL and COPYING.LGPL). + + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} {$INCLUDE wst_global.inc} unit test_utilities; diff --git a/wst/trunk/tests/test_suite/testformatter_unit.pas b/wst/trunk/tests/test_suite/testformatter_unit.pas index e5cc69d42..e10ae12a4 100644 --- a/wst/trunk/tests/test_suite/testformatter_unit.pas +++ b/wst/trunk/tests/test_suite/testformatter_unit.pas @@ -1,6 +1,6 @@ { This file is part of the Web Service Toolkit - Copyright (c) 2006 by Inoussa OUEDRAOGO + Copyright (c) 2006, 2007 by Inoussa OUEDRAOGO This file is provide under modified LGPL licence ( the files COPYING.modifiedLGPL and COPYING.LGPL). @@ -503,6 +503,17 @@ type procedure ExceptBlock_server(); procedure ExceptBlock_client(); end; + + { TTest_BinaryFormatterExceptionBlock } + + TTest_BinaryFormatterExceptionBlock = class(TTestCase) + protected + function CreateFormatter():IFormatterResponse; + function CreateFormatterClient():IFormatterClient; + published + procedure ExceptBlock_server(); + procedure ExceptBlock_client(); + end; implementation uses base_binary_formatter, base_soap_formatter, base_xmlrpc_formatter, record_rtti, @@ -514,7 +525,8 @@ uses base_binary_formatter, base_soap_formatter, base_xmlrpc_formatter, record_r , DOM, XMLRead, wst_fpc_xml {$ENDIF} , server_service_soap, soap_formatter, - server_service_xmlrpc, xmlrpc_formatter; + server_service_xmlrpc, xmlrpc_formatter, + binary_streamer, server_binary_formatter, binary_formatter; function TTestFormatterSimpleType.Support_ComplextType_with_SimpleContent( ): Boolean; begin @@ -3725,6 +3737,130 @@ begin end; end; +{ TTest_BinaryFormatterExceptionBlock } + +function TTest_BinaryFormatterExceptionBlock.CreateFormatter() : IFormatterResponse; +begin + Result := server_binary_formatter.TBinaryFormatter.Create() as IFormatterResponse; +end; + +function TTest_BinaryFormatterExceptionBlock.CreateFormatterClient() : IFormatterClient; +begin + Result := binary_formatter.TBinaryFormatter.Create() as IFormatterClient; +end; + +function loc_FindObj(const AOwner: PDataBuffer; const AName : TDataName) : PDataBuffer; +Var + p : PObjectBufferItem; +Begin + Assert(AOwner^.DataType >= dtObject); + Result := Nil; + p:= AOwner^.ObjectData^.Head; + While Assigned(p) Do Begin + If AnsiSameText(AName,p^.Data^.Name) Then Begin + Result := p^.Data; + Exit; + End; + p := p^.Next; + End; +End; + +procedure TTest_BinaryFormatterExceptionBlock.ExceptBlock_server(); +const VAL_CODE = '1210'; VAL_MSG = 'This is a sample exception message.'; +var + f : IFormatterResponse; + strm : TMemoryStream; + root, bodyNode, faultNode, tmpNode : PDataBuffer; + excpt_code, excpt_msg : string; +begin + root := nil; + f := CreateFormatter(); + f.BeginExceptionList(VAL_CODE,VAL_MSG); + f.EndExceptionList(); + strm := TMemoryStream.Create(); + try + f.SaveToStream(strm); + strm.Position := 0; + root := LoadObjectFromStream(CreateBinaryReader(strm)); + Check(Assigned(root)); + CheckEquals(Ord(dtObject), Ord(root^.DataType),'root^.DataType'); + Check(Assigned(root^.ObjectData),'root^.ObjectData'); + CheckEquals(False,root^.ObjectData^.NilObject,'root^.NilObject'); + Check(root^.ObjectData^.Count > 0, 'root^.Count'); + bodyNode := root^.ObjectData^.Head^.Data; + Check(Assigned(bodyNode),'body'); + CheckEquals(Ord(dtObject), Ord(bodyNode^.DataType),'body.DataType'); + CheckEquals(False,bodyNode^.ObjectData^.NilObject,'body.NilObject'); + Check(bodyNode^.ObjectData^.Count > 0, 'body.Count'); + + faultNode := bodyNode^.ObjectData^.Head^.Data; + Check(Assigned(faultNode),'fault'); + CheckEquals(Ord(dtObject), Ord(faultNode^.DataType),'fault.DataType'); + CheckEquals(False,faultNode^.ObjectData^.NilObject,'fault.NilObject'); + Check(faultNode^.ObjectData^.Count > 0, 'fault.Count'); + + tmpNode := loc_FindObj(faultNode,'faultcode'); + Check(Assigned(tmpNode),'faultcode'); + CheckEquals(Ord(dtString), Ord(tmpNode^.DataType),'faultcode.DataType'); + excpt_code := tmpNode^.StrData^.Data; + CheckEquals(VAL_CODE,excpt_code,'faultCode'); + + tmpNode := loc_FindObj(faultNode,'faultstring'); + Check(Assigned(tmpNode),'faultstring'); + CheckEquals(Ord(dtString), Ord(tmpNode^.DataType),'faultstring.DataType'); + excpt_msg := tmpNode^.StrData^.Data; + CheckEquals(VAL_MSG,excpt_msg,'faultString'); + finally + FreeAndNil(strm); + ClearObj(root); + end; +end; + +procedure TTest_BinaryFormatterExceptionBlock.ExceptBlock_client(); +const + VAL_CODE = '1210'; VAL_MSG = 'This is a sample exception message.'; +var + f : IFormatterClient; + strm : TMemoryStream; + root, bodyNode, faultNode, tmpNode : PDataBuffer; + excpt_code, excpt_msg : string; + locStore : IDataStore; +begin + excpt_code := ''; + excpt_msg := ''; + root := CreateObjBuffer(dtObject,'ROOT'); + try + bodyNode := CreateObjBuffer(dtObject,'Body',root); + faultNode := CreateObjBuffer(dtObject,'Fault',bodyNode); + CreateObjBuffer(dtString,'faultCode',faultNode)^.StrData^.Data := VAL_CODE; + CreateObjBuffer(dtString,'faultString',faultNode)^.StrData^.Data := VAL_MSG; + f := CreateFormatterClient(); + strm := TMemoryStream.Create(); + try + locStore := CreateBinaryWriter(strm); + SaveObjectToStream(root,locStore); + locStore := nil; + strm.Position := 0; + f.LoadFromStream(strm); + try + f.BeginCallRead(nil); + Check(False,'BeginCallRead() should raise an exception.'); + except + on e : EBinaryException do begin + excpt_code := e.FaultCode; + excpt_msg := e.FaultString; + end; + end; + CheckEquals(VAL_CODE,excpt_code,'faultCode'); + CheckEquals(VAL_MSG,excpt_msg,'faultString'); + finally + FreeAndNil(strm); + end; + finally + ClearObj(root); + end; +end; + initialization RegisterStdTypes(); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TTestEnum),'TTestEnum').RegisterExternalPropertyName('teOne', '1'); @@ -3766,6 +3902,8 @@ initialization {$IFDEF WST_RECORD_RTTI} GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestRecord)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(__TTestRecord_TYPEINFO_FUNC__()),GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestRecord)].GetExternalPropertyName('__FIELDS__'))); {$ENDIF WST_RECORD_RTTI} + RegisterAttributeProperty(TypeInfo(TTestSmallRecord),'fieldWord'); + RegisterAttributeProperty(TypeInfo(TTestRecord),'fieldWord'); {$IFDEF FPC} RegisterTest(TTestArray); @@ -3782,6 +3920,7 @@ initialization RegisterTest(TTestXmlRpcFormatter); RegisterTest(TTest_SoapFormatterExceptionBlock); RegisterTest(TTest_XmlRpcFormatterExceptionBlock); + RegisterTest(TTest_BinaryFormatterExceptionBlock); {$ELSE} RegisterTest(TTestArray.Suite); RegisterTest(TTestSOAPFormatter.Suite); @@ -3797,6 +3936,7 @@ initialization RegisterTest(TTestXmlRpcFormatter.Suite); RegisterTest(TTest_SoapFormatterExceptionBlock.Suite); RegisterTest(TTest_XmlRpcFormatterExceptionBlock.Suite); + RegisterTest(TTest_BinaryFormatterExceptionBlock.Suite); {$ENDIF} diff --git a/wst/trunk/tests/test_suite/wst_test_suite.lpi b/wst/trunk/tests/test_suite/wst_test_suite.lpi index ce091b8e0..1e7dd526b 100644 --- a/wst/trunk/tests/test_suite/wst_test_suite.lpi +++ b/wst/trunk/tests/test_suite/wst_test_suite.lpi @@ -27,7 +27,7 @@ - + @@ -40,12 +40,12 @@ - - - + + + - + @@ -55,27 +55,23 @@ - - - - - + + - - - - + + + @@ -83,8 +79,8 @@ - - + + @@ -97,42 +93,36 @@ - - - + + - - - - + + - - + - - + - - - - + + + @@ -175,9 +165,9 @@ - - - + + + @@ -186,63 +176,63 @@ - + - + - - + + - - - - + + + + - + - + - + - + - + @@ -251,22 +241,22 @@ - + - + - - - - + + + + @@ -274,7 +264,7 @@ - + @@ -282,168 +272,166 @@ - + - + - + - + - + - - - - - + + + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - - + + + - - - + + + - - - + + + - + @@ -452,16 +440,16 @@ - + - - - - + + + + @@ -469,60 +457,60 @@ - + - + - + - + - - - + + + - + - + - + - + @@ -532,7 +520,7 @@ - + @@ -542,7 +530,7 @@ - + @@ -552,7 +540,7 @@ - + @@ -562,7 +550,7 @@ - + @@ -572,22 +560,22 @@ - + - + - - - - + + + + @@ -595,52 +583,152 @@ - + - - - + - - + + - + + + + + + + - + - + - + - + - - + + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/wst_global.inc b/wst/trunk/wst_global.inc index 6b6fe9361..888166118 100644 --- a/wst/trunk/wst_global.inc +++ b/wst/trunk/wst_global.inc @@ -7,6 +7,7 @@ {$UNDEF USE_INLINE} {$DEFINE WST_RECORD_RTTI} {$ENDIF} + {$IFDEF CPU86} {$DEFINE HAS_COMP} {$ENDIF}