diff --git a/wst/trunk/base_binary_formatter.pas b/wst/trunk/base_binary_formatter.pas index 150f5afea..7b2ae8a77 100644 --- a/wst/trunk/base_binary_formatter.pas +++ b/wst/trunk/base_binary_formatter.pas @@ -18,7 +18,6 @@ uses Classes, SysUtils, Contnrs, TypInfo, base_service_intf, binary_streamer; -{$INCLUDE wst.inc} {$DEFINE wst_binary_header} const @@ -220,6 +219,11 @@ type Const ATypeInfo : PTypeInfo; Const AData : TObject ); + procedure PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer + ); function GetDataBuffer(var AName : String):PDataBuffer; procedure GetEnum( @@ -257,6 +261,11 @@ type Var AName : String; Var AData : TObject ); + procedure GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer + ); public constructor Create();override; destructor Destroy();override; @@ -909,6 +918,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Save(AData As TBaseRemotable, Self,AName,ATypeInfo); end; +procedure TBaseBinaryFormatter.PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer +); +begin + TRemotableRecordEncoder.Save(AData,Self,AName,ATypeInfo); +end; + function TBaseBinaryFormatter.GetDataBuffer(var AName: String): PDataBuffer; begin Result := StackTop().Find(AName); @@ -1001,6 +1019,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Load(AData, Self,AName,ATypeInfo); end; +procedure TBaseBinaryFormatter.GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer +); +begin + TRemotableRecordEncoder.Load(AData, Self,AName,ATypeInfo); +end; + procedure TBaseBinaryFormatter.Clear(); begin ClearStack(); @@ -1141,6 +1168,10 @@ begin objData := TObject(AData); PutObj(AName,ATypeInfo,objData); End; + tkRecord : + begin + PutRecord(AName,ATypeInfo,Pointer(@AData)); + end; {$IFDEF FPC} tkBool : Begin @@ -1340,6 +1371,7 @@ Var boolData : Boolean; enumData : TEnumData; floatDt : TFloat_Extended_10; + recObject : Pointer; begin Case ATypeInfo^.Kind Of tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : @@ -1360,6 +1392,11 @@ begin GetObj(ATypeInfo,AName,objData); TObject(AData) := objData; End; + tkRecord : + begin + recObject := Pointer(@AData); + GetRecord(ATypeInfo,AName,recObject); + end; {$IFDEF FPC} tkBool : Begin @@ -1405,7 +1442,7 @@ begin ftDouble : Double(AData) := floatDt; ftExtended : Extended(AData) := floatDt; ftCurr : Currency(AData) := floatDt; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} ftComp : Comp(AData) := floatDt; {$ENDIF} End; @@ -1476,7 +1513,7 @@ begin ftDouble : Double(AData) := dataBuffer^.DoubleData; ftExtended : Extended(AData) := dataBuffer^.ExtendedData; ftCurr : Currency(AData) := dataBuffer^.CurrencyData; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} else Comp(AData) := dataBuffer^.ExtendedData; {$ENDIF} diff --git a/wst/trunk/base_service_intf.pas b/wst/trunk/base_service_intf.pas index e6f04fcf7..0e12b525f 100644 --- a/wst/trunk/base_service_intf.pas +++ b/wst/trunk/base_service_intf.pas @@ -11,20 +11,19 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. } {$INCLUDE wst_global.inc} +{$RANGECHECKS OFF} + unit base_service_intf; interface uses - Classes, SysUtils, TypInfo, Contnrs, syncobjs, semaphore + Classes, SysUtils, TypInfo, Contnrs, syncobjs, semaphore, wst_types {$IFNDEF FPC} ,Windows {$ENDIF} ; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - const stBase = 0; stObject = stBase + 1; @@ -67,8 +66,11 @@ type property FaultString : string Read FFaultString Write FFaultString; End; - ETypeRegistryException = class(EServiceException) - End; + EServiceConfigException = class(EServiceException) + end; + + ETypeRegistryException = class(EServiceConfigException) + end; IItemFactory = Interface; IFormatterBase = Interface; @@ -358,6 +360,26 @@ type );override; end; + TRemotableRecordEncoderClass = class of TRemotableRecordEncoder; + + { TRemotableRecordEncoder } + + TRemotableRecordEncoder = class(TPersistent) + public + class procedure Save( + ARecord : Pointer; + AStore : IFormatterBase; + const AName : string; + const ATypeInfo : PTypeInfo + );virtual; + class procedure Load( + var ARecord : Pointer; + AStore : IFormatterBase; + var AName : string; + const ATypeInfo : PTypeInfo + );virtual; + end; + { TBaseComplexSimpleContentRemotable } TBaseComplexSimpleContentRemotable = class(TAbstractComplexRemotable) @@ -1115,6 +1137,8 @@ type FSynonymTable : TStrings; FExternalNames : TStrings; FInternalNames : TStrings; + private + procedure CreateInternalObjects(); public constructor Create( ANameSpace : string; @@ -1128,6 +1152,9 @@ type procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); function GetExternalPropertyName(const APropName : string) : string; function GetInternalPropertyName(const AExtPropName : string) : string; + + procedure RegisterObject(const APropName : string; const AObject : TObject); + function GetObject(const APropName : string) : TObject; property DataType : PTypeInfo read FDataType; property NameSpace : string read FNameSpace; @@ -1193,6 +1220,7 @@ const sWST_BASE_NS = 'urn:wst_base'; PROP_LIST_DELIMITER = ';'; + FIELDS_STRING = '__FIELDS__'; function GetTypeRegistry():TTypeRegistry; procedure RegisterStdTypes(); @@ -1210,9 +1238,12 @@ var {$ENDIF} implementation -uses imp_utils; +uses imp_utils, record_rtti; -Var +type + PObject = ^TObject; + +var TypeRegistryInstance : TTypeRegistry = Nil; function GetTypeRegistry():TTypeRegistry; @@ -1582,7 +1613,7 @@ begin AStore.SetSerializationStyle(ss); prpName := typRegItem.GetExternalPropertyName(p^.Name); case pt^.Kind of - tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : + tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} : begin int64Data := GetInt64Prop(AObject,p^.Name); AStore.Put(prpName,pt,int64Data); @@ -1675,7 +1706,7 @@ begin floatDt.CurrencyData := GetFloatProp(AObject,p^.Name); AStore.Put(prpName,pt,floatDt.CurrencyData); end; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} ftComp : begin floatDt.CompData := GetFloatProp(AObject,p^.Name); @@ -1752,7 +1783,7 @@ begin AStore.SetSerializationStyle(ss); try Case pt^.Kind Of - tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : + tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} : begin AStore.Get(pt,propName,int64Data); SetInt64Prop(AObject,p^.Name,int64Data); @@ -2113,7 +2144,8 @@ end; constructor TSimpleItemFactory.Create(AItemClass: TSimpleFactoryItemClass); begin - Assert(Assigned(AItemClass)); + if not Assigned(AItemClass) then + raise EServiceConfigException.CreateFmt('Invalid parameter : %s; Procedure = %s',['AItemClass','TSimpleItemFactory.Create()']); FItemClass := AItemClass; end; @@ -2331,6 +2363,14 @@ end; { TTypeRegistryItem } +procedure TTypeRegistryItem.CreateInternalObjects(); +begin + if not Assigned(FExternalNames) then begin + FExternalNames := TStringList.Create(); + FInternalNames := TStringList.Create(); + end; +end; + constructor TTypeRegistryItem.Create( ANameSpace : String; ADataType : PTypeInfo; @@ -2375,13 +2415,39 @@ end; procedure TTypeRegistryItem.RegisterExternalPropertyName(const APropName,AExtPropName: string); begin if not Assigned(FExternalNames) then begin - FExternalNames := TStringList.Create(); - FInternalNames := TStringList.Create(); + CreateInternalObjects(); end; FExternalNames.Values[APropName] := AExtPropName; FInternalNames.Values[AExtPropName] := APropName; end; +procedure TTypeRegistryItem.RegisterObject(const APropName : string; const AObject : TObject); +var + i : PtrInt; +begin + if not Assigned(FExternalNames) then begin + CreateInternalObjects(); + end; + i := FExternalNames.IndexOfName(APropName); + if ( i < 0 ) then begin + FExternalNames.Values[APropName] := APropName; + i := FExternalNames.IndexOfName(APropName); + end; + FExternalNames.Objects[i] := AObject; +end; + +function TTypeRegistryItem.GetObject(const APropName : string) : TObject; +var + i : PtrInt; +begin + Result := nil; + if Assigned(FExternalNames) then begin + i := FExternalNames.IndexOfName(APropName); + if ( i >= 0 ) then + Result := FExternalNames.Objects[i]; + end; +end; + function TTypeRegistryItem.GetExternalPropertyName(const APropName: string): string; begin if Assigned(FExternalNames) and ( FExternalNames.IndexOfName(APropName) <> -1 ) then begin @@ -3503,7 +3569,7 @@ begin Assigned(p^.SetProc) then begin case p^.PropType^.Kind of - tkInt64{$IFDEF FPC},tkQWord, tkBool{$ENDIF}, tkEnumeration,tkInteger : + tkInt64{$IFDEF HAS_QWORD} ,tkQWord{$ENDIF} {$IFDEF FPC} ,tkBool{$ENDIF}, tkEnumeration,tkInteger : SetOrdProp(Self,p,GetOrdProp(Source,p^.Name)); tkLString{$IFDEF FPC}, tkAString{$ENDIF} : SetStrProp(Self,p,GetStrProp(Source,p^.Name)); @@ -3581,7 +3647,7 @@ begin propName := tr.ItemByTypeInfo[pt].GetExternalPropertyName(p^.Name); if IsStoredProp(AObject,p) then begin case pt^.Kind of - tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : + tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} : begin int64Data := GetOrdProp(AObject,p^.Name); AStore.Put(propName,pt,int64Data); @@ -3674,7 +3740,7 @@ begin floatDt.CurrencyData := GetFloatProp(AObject,p^.Name); AStore.Put(propName,pt,floatDt.CurrencyData); end; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} ftComp : begin floatDt.CompData := GetFloatProp(AObject,p^.Name); @@ -3744,7 +3810,7 @@ begin propName := tr.ItemByTypeInfo[pt].GetExternalPropertyName(p^.Name); try Case pt^.Kind Of - tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : + tkInt64{$IFDEF HAS_QWORD},tkQWord{$ENDIF} : Begin AStore.Get(pt,propName,int64Data); SetOrdProp(AObject,p^.Name,int64Data); @@ -4512,6 +4578,219 @@ begin end; end; +{ TRemotableRecordEncoder } + +class procedure TRemotableRecordEncoder.Save( + ARecord : Pointer; + AStore : IFormatterBase; + const AName : string; + const ATypeInfo : PTypeInfo +); +var + recStart, recFieldAddress : PByte; + typData : PRecordTypeData; + i : PtrInt; + pt : PTypeInfo; + p : PRecordFieldInfo; + oldSS,ss : TSerializationStyle; + typRegItem : TTypeRegistryItem; + prpName : string; + typDataObj : TObject; +begin + oldSS := AStore.GetSerializationStyle(); + AStore.BeginObject(AName,ATypeInfo); + try + if not Assigned(ARecord) then begin + AStore.NilCurrentScope(); + Exit; + end; + typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo]; + typDataObj := typRegItem.GetObject(FIELDS_STRING); + Assert(Assigned(typDataObj),Format('Incomplete type registration for the type of this parameter : %s',[AName])); + typData := PRecordTypeData((typDataObj as TDataObject).Data); + Assert(Assigned(typData)); + if ( typData^.FieldCount > 0 ) then begin + recStart := PByte(ARecord); + ss := AStore.GetSerializationStyle(); + for i := 0 to Pred(typData^.FieldCount) do begin + p := @(typData^.Fields[i]); + 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 + {$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; + {$ENDIF} + end; + tkFloat : + begin + case GetTypeData(pt)^.FloatType of + ftSingle : AStore.Put(prpName,pt,PSingle(recFieldAddress)^); + ftDouble : AStore.Put(prpName,pt,PDouble(recFieldAddress)^); + ftExtended : AStore.Put(prpName,pt,PExtended(recFieldAddress)^); + ftCurr : AStore.Put(prpName,pt,PCurrency(recFieldAddress)^); +{$IFDEF HAS_COMP} + ftComp : AStore.Put(prpName,pt,PComp(recFieldAddress)^); +{$ENDIF} + end; + end; + end; + end; + end; + finally + AStore.EndScope(); + AStore.SetSerializationStyle(oldSS); + end; +end; + +class procedure TRemotableRecordEncoder.Load( + var ARecord : Pointer; + AStore : IFormatterBase; + var AName : string; + const ATypeInfo : PTypeInfo +); +var + recStart, recFieldAddress : PByte; + typData : PRecordTypeData; + i : PtrInt; + pt : PTypeInfo; + propName : String; + p : PRecordFieldInfo; + persistType : TPropStoreType; + oldSS,ss : TSerializationStyle; + typRegItem : TTypeRegistryItem; + typDataObj : TObject; +begin + oldSS := AStore.GetSerializationStyle(); + if ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin + try + if AStore.IsCurrentScopeNil() then + Exit; + typRegItem := GetTypeRegistry().ItemByTypeInfo[ATypeInfo]; + typDataObj := typRegItem.GetObject(FIELDS_STRING); + Assert(Assigned(typDataObj),Format('Incomplete type registration for the type of this parameter : %s',[AName])); + typData := PRecordTypeData((typDataObj as TDataObject).Data); + Assert(Assigned(typData)); + if ( not Assigned(ARecord) ) then begin + GetMem(ARecord,typData^.RecordSize); + FillChar(ARecord^,typData^.RecordSize,#0); + end; + + if ( typData^.FieldCount > 0 ) then begin + recStart := PByte(ARecord); + for i := 0 to Pred(typData^.FieldCount) do begin + p := @(typData^.Fields[i]); + 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; + end; + end; + end; + end; + finally + AStore.EndScopeRead(); + AStore.SetSerializationStyle(oldSS); + end; + end; +end; initialization {$IFDEF FPC} diff --git a/wst/trunk/base_soap_formatter.pas b/wst/trunk/base_soap_formatter.pas index 0bf8ab51d..255e3a7d0 100644 --- a/wst/trunk/base_soap_formatter.pas +++ b/wst/trunk/base_soap_formatter.pas @@ -20,9 +20,6 @@ uses {$IFNDEF FPC}xmldom, wst_delphi_xml{$ELSE}DOM{$ENDIF}, base_service_intf; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - const sPROTOCOL_NAME = 'SOAP'; @@ -183,7 +180,12 @@ type Const ATypeInfo : PTypeInfo; Const AData : TObject ); - + procedure PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer + ); + function GetNodeValue(var AName : String):DOMString; procedure GetEnum( Const ATypeInfo : PTypeInfo; @@ -222,6 +224,11 @@ type Var AName : String; Var AData : TObject ); + procedure GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer + ); protected function GetXmlDoc():TwstXMLDocument; function PushStack(AScopeObject : TDOMNode):TStackItem;overload; @@ -313,18 +320,18 @@ type procedure EndHeader(); procedure Put( - Const AName : String; - Const ATypeInfo : PTypeInfo; - Const AData + const AName : string; + const ATypeInfo : PTypeInfo; + const AData ); procedure PutScopeInnerValue( const ATypeInfo : PTypeInfo; const AData ); procedure Get( - Const ATypeInfo : PTypeInfo; - Var AName : String; - Var AData + const ATypeInfo : PTypeInfo; + var AName : string; + var AData ); procedure GetScopeInnerValue( const ATypeInfo : PTypeInfo; @@ -515,6 +522,7 @@ procedure TSOAPBaseFormatter.InternalClear(const ACreateDoc: Boolean); begin ClearStack(); ReleaseDomNode(FDoc); + FDoc := nil; if ACreateDoc then FDoc := CreateDoc(); end; @@ -738,6 +746,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Save(AData As TBaseRemotable, Self,AName,ATypeInfo); end; +procedure TSOAPBaseFormatter.PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer +); +begin + TRemotableRecordEncoder.Save(AData,Self,AName,ATypeInfo); +end; + function TSOAPBaseFormatter.PutFloat( const AName : String; const ATypeInfo : PTypeInfo; @@ -888,6 +905,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Load(AData, Self,AName,ATypeInfo); end; +procedure TSOAPBaseFormatter.GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer +); +begin + TRemotableRecordEncoder.Load(AData, Self,AName,ATypeInfo); +end; + function TSOAPBaseFormatter.GetXmlDoc(): TwstXMLDocument; begin Result := FDoc; @@ -1375,6 +1401,10 @@ begin objData := TObject(AData); PutObj(AName,ATypeInfo,objData); End; + tkRecord : + begin + PutRecord(AName,ATypeInfo,Pointer(@AData)); + end; {$IFDEF FPC} tkBool : Begin @@ -1548,6 +1578,7 @@ Var boolData : Boolean; enumData : TEnumIntType; floatDt : Extended; + recObject : Pointer; begin Case ATypeInfo^.Kind Of tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : @@ -1568,6 +1599,11 @@ begin GetObj(ATypeInfo,AName,objData); TObject(AData) := objData; End; + tkRecord : + begin + recObject := Pointer(@AData); + GetRecord(ATypeInfo,AName,recObject); + end; {$IFDEF FPC} tkBool : Begin diff --git a/wst/trunk/base_xmlrpc_formatter.pas b/wst/trunk/base_xmlrpc_formatter.pas index 486a77008..5339f105b 100644 --- a/wst/trunk/base_xmlrpc_formatter.pas +++ b/wst/trunk/base_xmlrpc_formatter.pas @@ -20,9 +20,6 @@ uses {$IFNDEF FPC}xmldom, wst_delphi_xml{$ELSE}DOM{$ENDIF}, base_service_intf; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - const sPROTOCOL_NAME = 'XMLRPC'; @@ -195,6 +192,11 @@ type Const ATypeInfo : PTypeInfo; Const AData : TObject ); + procedure PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer + ); function GetNodeValue(var AName : String):DOMString; procedure GetEnum( @@ -234,6 +236,11 @@ type Var AName : String; Var AData : TObject ); + procedure GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer + ); protected function GetXmlDoc():TXMLDocument; function PushStack(AScopeObject : TDOMNode):TStackItem;overload; @@ -573,6 +580,7 @@ procedure TXmlRpcBaseFormatter.InternalClear(const ACreateDoc: Boolean); begin ClearStack(); ReleaseDomNode(FDoc); + FDoc := nil; if ACreateDoc then FDoc := CreateDoc(); end; @@ -732,6 +740,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Save(AData As TBaseRemotable, Self,AName,ATypeInfo); end; +procedure TXmlRpcBaseFormatter.PutRecord( + const AName : string; + const ATypeInfo : PTypeInfo; + const AData : Pointer +); +begin + TRemotableRecordEncoder.Save(AData,Self,AName,ATypeInfo); +end; + function TXmlRpcBaseFormatter.PutFloat( const AName : String; const ATypeInfo : PTypeInfo; @@ -864,6 +881,15 @@ begin TBaseRemotableClass(GetTypeData(ATypeInfo)^.ClassType).Load(AData, Self,AName,ATypeInfo); end; +procedure TXmlRpcBaseFormatter.GetRecord( + const ATypeInfo : PTypeInfo; + var AName : String; + var AData : Pointer +); +begin + TRemotableRecordEncoder.Load(AData, Self,AName,ATypeInfo); +end; + function TXmlRpcBaseFormatter.GetXmlDoc(): TwstXMLDocument; begin Result := FDoc; @@ -1056,6 +1082,10 @@ begin objData := TObject(AData); PutObj(AName,ATypeInfo,objData); End; + tkRecord : + begin + PutRecord(AName,ATypeInfo,Pointer(@AData)); + end; {$IFDEF FPC} tkBool : Begin @@ -1218,6 +1248,7 @@ Var {$IFDEF FPC}boolData : Boolean;{$ENDIF} enumData : TEnumIntType; floatDt : Extended; + recObject : Pointer; begin Case ATypeInfo^.Kind Of tkInt64{$IFDEF FPC},tkQWord{$ENDIF} : @@ -1238,6 +1269,11 @@ begin GetObj(ATypeInfo,AName,objData); TObject(AData) := objData; End; + tkRecord : + begin + recObject := Pointer(@AData); + GetRecord(ATypeInfo,AName,recObject); + end; {$IFDEF FPC} tkBool : Begin @@ -1271,7 +1307,7 @@ begin ftDouble : Double(AData) := floatDt; ftExtended : Extended(AData) := floatDt; ftCurr : Currency(AData) := floatDt; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} ftComp : Comp(AData) := floatDt; {$ENDIF} End; @@ -1347,7 +1383,7 @@ begin ftDouble : Double(AData) := floatDt; ftExtended : Extended(AData) := floatDt; ftCurr : Currency(AData) := floatDt; -{$IFDEF CPU86} +{$IFDEF HAS_COMP} ftComp : Comp(AData) := floatDt; {$ENDIF} end; diff --git a/wst/trunk/binary_formatter.pas b/wst/trunk/binary_formatter.pas index 14a8b87ee..97824154b 100644 --- a/wst/trunk/binary_formatter.pas +++ b/wst/trunk/binary_formatter.pas @@ -20,9 +20,6 @@ uses base_service_intf, service_intf, imp_utils, base_binary_formatter; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - Const sCONTENT_TYPE = 'contenttype'; sBINARY_CONTENT = 'binary'; diff --git a/wst/trunk/ics_http_protocol.pas b/wst/trunk/ics_http_protocol.pas index 1f469e3ea..0f19242a5 100644 --- a/wst/trunk/ics_http_protocol.pas +++ b/wst/trunk/ics_http_protocol.pas @@ -22,9 +22,6 @@ uses service_intf, imp_utils, base_service_intf, HttpProt; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - Const sTRANSPORT_NAME = 'HTTP'; diff --git a/wst/trunk/ics_tcp_protocol.pas b/wst/trunk/ics_tcp_protocol.pas index 3e52334cd..2cfa35c56 100644 --- a/wst/trunk/ics_tcp_protocol.pas +++ b/wst/trunk/ics_tcp_protocol.pas @@ -20,8 +20,6 @@ uses service_intf, imp_utils, base_service_intf, WSocket; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} Const sTRANSPORT_NAME = 'TCP'; diff --git a/wst/trunk/imp_utils.pas b/wst/trunk/imp_utils.pas index 013f7417c..3e52a7bac 100644 --- a/wst/trunk/imp_utils.pas +++ b/wst/trunk/imp_utils.pas @@ -19,9 +19,6 @@ uses Classes, SysUtils, TypInfo, base_service_intf; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - Type EPropertyManagerException = class(EServiceException) @@ -46,15 +43,35 @@ Type End; function IsStrEmpty(Const AStr:String):Boolean; + function GetToken(var ABuffer : string; const ADelimiter : string): string; function ExtractOptionName(const ACompleteName : string):string; implementation +uses wst_types; function IsStrEmpty(Const AStr:String):Boolean; begin Result := ( Length(Trim(AStr)) = 0 ); end; +function GetToken(var ABuffer : string; const ADelimiter : string): string; +var + locPos, locOfs, locLen : PtrInt; + locStr : string; +begin + locPos := Pos(ADelimiter, ABuffer); + locLen := Length(ADelimiter); + locOfs := locLen - 1; + if (IsStrEmpty(ABuffer)) or ((locPos = 0) and (Length(ABuffer) > 0)) then begin + Result := ABuffer; + ABuffer := ''; + end else begin + locStr := Copy(ABuffer, 1, locPos + locOfs); + ABuffer := Copy(ABuffer, locPos + locLen, Length(ABuffer)); + Result := Copy(locStr, 1, Length(locStr) - locLen); + end; +end; + function ExtractOptionName(const ACompleteName : string):string; var i, c : Integer; diff --git a/wst/trunk/indy_http_server.pas b/wst/trunk/indy_http_server.pas index 3c1f9b9d5..ad21d6837 100644 --- a/wst/trunk/indy_http_server.pas +++ b/wst/trunk/indy_http_server.pas @@ -209,9 +209,9 @@ procedure TwstIndyHttpListener.Handler_CommandGet( var {$IFDEF WST_DBG} s : string; + j : SizeInt; {$ENDIF} locPath, locPathPart : string; - j : SizeInt; begin {$IFDEF WST_DBG} if Assigned(ARequestInfo.PostStream) and ( ARequestInfo.PostStream.Size > 0 ) then begin diff --git a/wst/trunk/library_protocol.pas b/wst/trunk/library_protocol.pas index ce29e82d8..f49a950cd 100644 --- a/wst/trunk/library_protocol.pas +++ b/wst/trunk/library_protocol.pas @@ -22,9 +22,6 @@ uses service_intf, imp_utils, base_service_intf, library_base_intf, library_imp_utils; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - const sTRANSPORT_NAME = 'LIB'; diff --git a/wst/trunk/metadata_repository.pas b/wst/trunk/metadata_repository.pas index e570101cf..4a9bef3e5 100644 --- a/wst/trunk/metadata_repository.pas +++ b/wst/trunk/metadata_repository.pas @@ -18,9 +18,6 @@ interface uses Classes, SysUtils, TypInfo; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - const sWST_SIGNATURE = 'WST_METADATA_0.2.2.0'; sWST_META = 'wst_meta'; diff --git a/wst/trunk/metadata_wsdl.pas b/wst/trunk/metadata_wsdl.pas index c95b17542..7db59a792 100644 --- a/wst/trunk/metadata_wsdl.pas +++ b/wst/trunk/metadata_wsdl.pas @@ -20,9 +20,6 @@ uses {$IFNDEF FPC}xmldom, wst_delphi_xml{$ELSE}DOM{$ENDIF}, base_service_intf, metadata_repository; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - type IWsdlTypeHandler = interface @@ -83,10 +80,11 @@ type implementation uses + wst_types {$IFNDEF FPC} - wst_delphi_rtti_utils + , wst_delphi_rtti_utils {$ELSE} - wst_fpc_xml, XmlWrite + , wst_fpc_xml, XmlWrite {$ENDIF}; const diff --git a/wst/trunk/record_rtti.pas b/wst/trunk/record_rtti.pas new file mode 100644 index 000000000..1ae9a2c6e --- /dev/null +++ b/wst/trunk/record_rtti.pas @@ -0,0 +1,323 @@ +{ + This file is part of the Web Service Toolkit + Copyright (c) 2006 by Inoussa OUEDRAOGO + + This file is provide under modified LGPL licence + ( the files COPYING.modifiedLGPL and COPYING.LGPL). + + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} +{$INCLUDE wst_global.inc} +unit record_rtti; + +{$RANGECHECKS OFF} + +interface + +uses + SysUtils, TypInfo, wst_types; + +type + + PRecordFieldInfo = ^TRecordFieldInfo; + TRecordFieldInfo = packed record + Name : shortstring; + TypeInfo : PPTypeInfo; + Offset : PtrUInt; + end; + + PRecordTypeData = ^TRecordTypeData; + TRecordTypeData = packed record + Name : shortstring; + RecordSize : PtrUInt; + FieldCount: PtrUInt; + Fields: array [0..0] of TRecordFieldInfo; + end; + + { TRecordRttiDataObject } + + TRecordRttiDataObject = class(TDataObject) + public + constructor Create(const AData : PRecordTypeData; const AFieldList : string); + destructor Destroy();override; + function GetRecordTypeData() : PRecordTypeData; + end; + + function MakeRecordTypeInfo(ARawTypeInfo : PTypeInfo) : PRecordTypeData; + procedure FreeRecordTypeInfo(ATypeInfo : PRecordTypeData); + +{$IFDEF WST_RECORD_RTTI} + function MakeRawTypeInfo( + const ATypeName : string; + const ATypeSize : PtrUInt; + const AOffset : array of PtrUInt; + const ATypes : array of PTypeInfo + ):PTypeInfo ; +{$ENDIF WST_RECORD_RTTI} + +implementation +uses Classes, imp_utils; + +{$IFDEF WST_RECORD_RTTI} + +var + RawTypeInfoList : TList = nil; + +type + PFieldInfo = ^TFieldInfo; + TFieldInfo = packed record + TypeInfo: PPTypeInfo; + Offset: Cardinal; + end; + + PFieldTable = ^TFieldTable; + TFieldTable = packed record + X: Word; + Size: Cardinal; + Count: Cardinal; + Fields: array [0..0] of TFieldInfo; + end; + +function MakeRawTypeInfo( + const ATypeName : string; + const ATypeSize : PtrUInt; + const AOffset : array of PtrUInt; + const ATypes : array of PTypeInfo +):PTypeInfo ; +var + i, j, bufferSize, count : LongInt; + delphiFT : PFieldTable; + resBuffer, tmp : PByte; + fieldInfo : PFieldInfo; + typ : PTypeInfo; +begin + count := Length(AOffset); + Assert(count = Length(ATypes)); + bufferSize := + 1 + // Kind + 1 + Length(ATypeName) + + SizeOf(Word) + // X + SizeOf(Cardinal) + // Size + SizeOf(Cardinal) + // Count + ( count * SizeOf(TFieldInfo) ); + GetMem(resBuffer,bufferSize); + FillChar(Pointer(resBuffer)^,bufferSize,#0); + tmp := resBuffer; + typ := PTypeInfo(resBuffer); + typ^.Kind := tkRecord; + PByte(@(typ^.Name[0]))^ := Length(ATypeName); + Move(ATypeName[1],typ^.Name[1],Length(ATypeName)); + + Inc(tmp,SizeOf(TTypeKind)); // Kind + Inc(tmp,1 + Byte(typ^.Name[0])); // Name + + delphiFT := PFieldTable(tmp); + delphiFT^.X := 0; + delphiFT^.Size := ATypeSize; + delphiFT^.Count := count; + for i := 1 to count do begin + j := i - 1; + fieldInfo := @(delphiFT^.Fields[j]); + fieldInfo^.Offset := AOffset[j]; + GetMem(fieldInfo^.TypeInfo,SizeOf(Pointer)); + fieldInfo^.TypeInfo^ := ATypes[j]; + end; + Result := typ; + RawTypeInfoList.Add(Result); +end; + +procedure FreeRawTypeInfo(ARawTypeInfo : PTypeInfo); +var + i : PtrInt; + delphiFT : PFieldTable; + tmp : PByte; + fieldInfo : PFieldInfo; +begin + if Assigned(ARawTypeInfo) then begin + tmp := PByte(ARawTypeInfo); + Inc(tmp,SizeOf(TTypeKind)); // Kind + Inc(tmp,1 + Byte(ARawTypeInfo^.Name[0])); // Name + + delphiFT := PFieldTable(tmp); + for i := 1 to delphiFT^.Count do begin + fieldInfo := @(delphiFT^.Fields[(i - 1)]); + FreeMem(fieldInfo^.TypeInfo); + fieldInfo^.TypeInfo := nil; + end; + FreeMem(ARawTypeInfo); + end; +end; + +function MakeRecordTypeInfo(ARawTypeInfo : PTypeInfo) : PRecordTypeData; +var + i, bufferSize, count : LongInt; + delphiFT : PFieldTable; + resBuffer : PRecordTypeData; + fieldInfo : PRecordFieldInfo; + fld : PFieldInfo; + tmp : PByte; +begin + tmp := PByte(ARawTypeInfo); + Inc(tmp); + Inc(tmp,1 + Byte(ARawTypeInfo.Name[0])); + delphiFT := PFieldTable(tmp); + count := delphiFT^.Count; + {calc buffer size} + bufferSize := + SizeOf(shortstring) + // Name : shortstring; + SizeOf(PtrUInt) + // Size : PtrUInt; + SizeOf(PtrUInt) + // FieldCount: PtrUInt; + ( count * SizeOf(TRecordFieldInfo) ); // Fields: array [0..0] of TRecordFieldInfo; + GetMem(resBuffer,bufferSize); + FillChar(Pointer(resBuffer)^,bufferSize,#0); + resBuffer^.Name := PTypeInfo(ARawTypeInfo).Name; + resBuffer^.RecordSize := delphiFT^.Size; + resBuffer^.FieldCount := count; + { Process elements } + for i := 1 to Count do begin + fld := @(delphiFT^.Fields[(i - 1)]); + fieldInfo := @(resBuffer^.Fields[(i - 1)]); + fieldInfo^.TypeInfo := fld^.TypeInfo; + fieldInfo^.Offset := fld^.Offset; + end; + Result := resBuffer; +end; +{$ENDIF WST_RECORD_RTTI} + +{$IFDEF FPC} +function aligntoptr(p : pointer) : pointer;inline; + begin +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + result:=align(p,sizeof(p)); +{$else FPC_REQUIRES_PROPER_ALIGNMENT} + result:=p; +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + end; + +function MakeRecordTypeInfo(ARawTypeInfo : PTypeInfo) : PRecordTypeData; +{ + A record is designed as follows : + 1 : tkrecord + 2 : Length of name string (n); + 3 : name string; + 3+n : record size; + 7+n : number of elements (N) + 11+n : N times : Pointer to type info + Offset in record +} +var + Temp : pbyte; + namelen : byte; + count, + offset, + i : longint; + info : pointer; + + resBuffer : PRecordTypeData; + typName : shortstring; + typSize : Cardinal; + bufferSize : PtrUInt; + fieldInfo : PRecordFieldInfo; +begin + Temp := PByte(ARawTypeInfo); + Inc(Temp); + { Skip Name } + namelen := Temp^; + SetLength(typName,namelen); + Inc(temp,1); + Move(Temp^,typName[1],namelen); + Inc(temp,namelen); + temp:=aligntoptr(temp); + { Skip size } + typSize := PLongint(Temp)^; + Inc(Temp,4); + { Element count } + Count := PLongint(Temp)^; + Inc(Temp,sizeof(Count)); + + {calc buffer size} + bufferSize := + SizeOf(shortstring) + // Name : shortstring; + SizeOf(PtrUInt) + // Size : PtrUInt; + SizeOf(PtrUInt) + // FieldCount: PtrUInt; + ( Count * SizeOf(TRecordFieldInfo) ); // Fields: array [0..0] of TRecordFieldInfo; + + GetMem(resBuffer,bufferSize); + FillChar(Pointer(resBuffer)^,bufferSize,#0); + resBuffer^.Name := typName; + resBuffer^.RecordSize := typSize; + resBuffer^.FieldCount := count; + { Process elements } + for i := 1 to Count do begin + fieldInfo := @(resBuffer^.Fields[(i - 1)]); + Info := PPointer(Temp)^; + fieldInfo^.TypeInfo := PPTypeInfo(Temp); + Inc(Temp,sizeof(Info)); + Offset := PLongint(Temp)^; + fieldInfo^.Offset := Offset; + Inc(Temp,sizeof(Offset)); + end; + Result := resBuffer; +end; +{$ENDIF FPC} + +procedure FreeRecordTypeInfo(ATypeInfo : PRecordTypeData); +begin + if ( ATypeInfo <> nil ) then + FreeMem(ATypeInfo); +end; + +{ TRecordRttiDataObject } + +constructor TRecordRttiDataObject.Create( + const AData : PRecordTypeData; + const AFieldList : string +); +var + locData : PRecordTypeData; + i : PtrInt; + ls, s : string; +begin + locData := AData; + inherited Create(locData); + ls := Trim(AFieldList); + s := ''; + i := 0; + while ( i < locData^.FieldCount ) do begin + s := GetToken(ls,';'); + if IsStrEmpty(s) then + Break; + locData^.Fields[i].Name := s; + Inc(i); + end; +end; + +destructor TRecordRttiDataObject.Destroy(); +begin + FreeRecordTypeInfo(Data); + inherited Destroy(); +end; + +function TRecordRttiDataObject.GetRecordTypeData() : PRecordTypeData; +begin + Result := PRecordTypeData(Data); +end; + +initialization +{$IFDEF WST_RECORD_RTTI} + RawTypeInfoList := TList.Create(); +{$ENDIF WST_RECORD_RTTI} + +finalization +{$IFDEF WST_RECORD_RTTI} + while ( RawTypeInfoList.Count > 0 ) do begin + FreeRawTypeInfo(PTypeInfo(RawTypeInfoList.Items[0])); + RawTypeInfoList.Delete(0); + end; + FreeAndNil(RawTypeInfoList); +{$ENDIF WST_RECORD_RTTI} + +end. diff --git a/wst/trunk/same_process_protocol.pas b/wst/trunk/same_process_protocol.pas index f747b975b..c99755d30 100644 --- a/wst/trunk/same_process_protocol.pas +++ b/wst/trunk/same_process_protocol.pas @@ -20,9 +20,6 @@ uses service_intf, imp_utils, server_service_intf, server_service_imputils, base_service_intf; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - Const sTRANSPORT_NAME = 'SAME_PROCESS'; diff --git a/wst/trunk/samples/amazon/amazon_sample.lpi b/wst/trunk/samples/amazon/amazon_sample.lpi index b6d3f390a..b00b1a33f 100644 --- a/wst/trunk/samples/amazon/amazon_sample.lpi +++ b/wst/trunk/samples/amazon/amazon_sample.lpi @@ -12,7 +12,7 @@ - + @@ -35,17 +35,17 @@ - + - + - - + + @@ -94,7 +94,12 @@ - + + + + + + diff --git a/wst/trunk/samples/http_server/http_server.lpi b/wst/trunk/samples/http_server/http_server.lpi index 461cba984..7e16a90bc 100644 --- a/wst/trunk/samples/http_server/http_server.lpi +++ b/wst/trunk/samples/http_server/http_server.lpi @@ -1,7 +1,7 @@ - + @@ -10,7 +10,7 @@ - + @@ -19,6 +19,7 @@ + @@ -26,7 +27,7 @@ - + @@ -53,7 +54,7 @@ - + @@ -62,7 +63,7 @@ - + @@ -71,14 +72,14 @@ - + - + @@ -87,7 +88,7 @@ - + @@ -96,7 +97,7 @@ - + @@ -106,7 +107,7 @@ - + @@ -115,14 +116,14 @@ - + - + @@ -131,234 +132,234 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -367,17 +368,17 @@ - + - + - + @@ -386,39 +387,39 @@ - + - + - + - + - + - + @@ -427,13 +428,13 @@ - + - + @@ -443,143 +444,131 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - - - - - - - - - - - - - + + - - + + - + @@ -605,19 +594,19 @@ - + - + - + - + diff --git a/wst/trunk/samples/library_server/lib_server.lpi b/wst/trunk/samples/library_server/lib_server.lpi index f5bb93cb4..4c89b824a 100644 --- a/wst/trunk/samples/library_server/lib_server.lpi +++ b/wst/trunk/samples/library_server/lib_server.lpi @@ -1,11 +1,11 @@ - + - + @@ -14,6 +14,7 @@ + @@ -21,7 +22,7 @@ - + @@ -36,7 +37,7 @@ - + @@ -45,25 +46,25 @@ - + - + - + - + - + @@ -72,25 +73,25 @@ - + - + - + - + - + @@ -99,30 +100,24 @@ - + - - - - - - - - + + - - + + @@ -144,19 +139,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 deda57a19..418c512d7 100644 --- a/wst/trunk/samples/user_client_console/user_client_console.lpi +++ b/wst/trunk/samples/user_client_console/user_client_console.lpi @@ -35,8 +35,8 @@ - - + + @@ -46,16 +46,16 @@ - + - - - + + + @@ -64,7 +64,7 @@ - + @@ -73,7 +73,7 @@ - + @@ -94,9 +94,9 @@ - - - + + + @@ -140,8 +140,8 @@ - - + + @@ -177,7 +177,7 @@ - + @@ -186,9 +186,7 @@ - - @@ -203,7 +201,7 @@ - + @@ -266,9 +264,7 @@ - - @@ -310,7 +306,7 @@ - + @@ -324,25 +320,27 @@ - - + + + + - - - + + + - - - + + + @@ -354,12 +352,19 @@ - - - + + + + + + + + + + diff --git a/wst/trunk/samples/user_client_console/user_client_console.pas b/wst/trunk/samples/user_client_console/user_client_console.pas index d8d02ffd3..a1872e60b 100644 --- a/wst/trunk/samples/user_client_console/user_client_console.pas +++ b/wst/trunk/samples/user_client_console/user_client_console.pas @@ -5,7 +5,7 @@ program user_client_console; uses Classes, SysUtils, TypInfo, {$IFDEF WINDOWS}ActiveX,{$ENDIF} user_service_intf_proxy, - same_process_protocol, synapse_tcp_protocol, synapse_http_protocol, library_protocol, //ics_tcp_protocol, ics_http_protocol, + same_process_protocol, synapse_tcp_protocol, synapse_http_protocol, library_protocol, ics_tcp_protocol, ics_http_protocol, soap_formatter, binary_formatter, user_service_intf, xmlrpc_formatter; diff --git a/wst/trunk/semaphore.pas b/wst/trunk/semaphore.pas index aa909e478..b85bc8cca 100644 --- a/wst/trunk/semaphore.pas +++ b/wst/trunk/semaphore.pas @@ -18,9 +18,6 @@ interface uses Classes, SysUtils, syncobjs{$IFNDEF FPC},Windows{$ENDIF}; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - type ESemaphoreException = class(Exception); diff --git a/wst/trunk/synapse_http_protocol.pas b/wst/trunk/synapse_http_protocol.pas index 49b62ce7d..836ccd6d1 100644 --- a/wst/trunk/synapse_http_protocol.pas +++ b/wst/trunk/synapse_http_protocol.pas @@ -22,9 +22,6 @@ uses service_intf, imp_utils, base_service_intf, httpsend; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - Const sTRANSPORT_NAME = 'HTTP'; @@ -157,6 +154,14 @@ end; procedure THTTPTransport.SendAndReceive(ARequest, AResponse: TStream); {$IFDEF WST_DBG} + procedure Display(const AStr : string); + begin + if IsConsole then + WriteLn(AStr) + {else + ShowMessage(AStr)}; + end; + var s : string; {$ENDIF} @@ -169,13 +174,13 @@ begin FConnection.Clear(); {$IFDEF WST_DBG} TMemoryStream(ARequest).SaveToFile('request.log'); + SetLength(s,ARequest.Size); + Move(TMemoryStream(ARequest).Memory^,s[1],Length(s)); + Display(s); SetLength(s,AResponse.Size); Move(TMemoryStream(AResponse).Memory^,s[1],Length(s)); TMemoryStream(AResponse).SaveToFile('response.log'); - if IsConsole then - WriteLn(s) - {else - ShowMessage(s)}; + Display(s); {$ENDIF} end; diff --git a/wst/trunk/synapse_tcp_protocol.pas b/wst/trunk/synapse_tcp_protocol.pas index cc2332f9e..ede00b1b1 100644 --- a/wst/trunk/synapse_tcp_protocol.pas +++ b/wst/trunk/synapse_tcp_protocol.pas @@ -20,10 +20,7 @@ uses service_intf, imp_utils, base_service_intf, blcksock; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - -{$DEFINE WST_DBG} +//{$DEFINE WST_DBG} Const sTRANSPORT_NAME = 'TCP'; diff --git a/wst/trunk/tests/calculator/srv/calculator.wst b/wst/trunk/tests/calculator/srv/calculator.wst index 8d987fa93..75b019de8 100644 --- a/wst/trunk/tests/calculator/srv/calculator.wst +++ b/wst/trunk/tests/calculator/srv/calculator.wst @@ -1,13 +1,13 @@ GetWSTResourceManager().AddResource('CALCULATOR', #0#0#0#20'WST_METADATA_0.2.2.0'#0#0#0#10'calculator'#1#0#0#0#11'ICalculator'#4 +#0#0#0#6'AddInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0 - +#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#17'TBinaryArgsResult'#0#0 + +#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'Result'#0#0#0#17'TBinaryArgsResult'#0#0 +#0#0#0#0#0#3#0#0#0#6'DivInt'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0 - +#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0#7'Integer'#0 + +#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'Result'#0#0#0#7'Integer'#0 +#0#0#0#0#0#0#3#0#0#0#15'DoAllOperations'#3#0#0#0#1'A'#0#0#0#7'Integer'#0#0#0 - +#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0 + +#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#6'Result'#0#0#0 +#22'TBinaryArgsResultArray'#0#0#0#0#0#0#0#3#0#0#0#11'DoOperation'#4#0#0#0#1'A' +#0#0#0#7'Integer'#0#0#0#0#0#0#0#1#0#0#0#1'B'#0#0#0#7'Integer'#0#0#0#0#0#0#0#1 - +#0#0#0#10'AOperation'#0#0#0#8'TCalc_Op'#0#0#0#0#0#0#0#1#0#0#0#6'result'#0#0#0 + +#0#0#0#10'AOperation'#0#0#0#8'TCalc_Op'#0#0#0#0#0#0#0#1#0#0#0#6'Result'#0#0#0 +#17'TBinaryArgsResult'#0#0#0#0#0#0#0#3'' ); \ No newline at end of file diff --git a/wst/trunk/tests/calculator/srv/calculator_binder.pas b/wst/trunk/tests/calculator/srv/calculator_binder.pas index 8ccc064fe..3112a5a65 100644 --- a/wst/trunk/tests/calculator/srv/calculator_binder.pas +++ b/wst/trunk/tests/calculator/srv/calculator_binder.pas @@ -2,10 +2,10 @@ This unit has been produced by ws_helper. Input unit name : "calculator". This unit name : "calculator_binder". - Date : "12/11/2006 11:22". + Date : "15/08/2007 16:34:20". } unit calculator_binder; -{$mode objfpc}{$H+} +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} interface uses SysUtils, Classes, base_service_intf, server_service_intf, calculator; @@ -13,20 +13,25 @@ uses SysUtils, Classes, base_service_intf, server_service_intf, calculator; type - TCalculator_ServiceBinder=class(TBaseServiceBinder) - Protected - procedure AddIntHandler(AFormatter:IFormatterResponse); - procedure DivIntHandler(AFormatter:IFormatterResponse); - procedure DoAllOperationsHandler(AFormatter:IFormatterResponse); - procedure DoOperationHandler(AFormatter:IFormatterResponse); - Public + TCalculator_ServiceBinder = class(TBaseServiceBinder) + protected + procedure AddIntHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + procedure DivIntHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + procedure DoAllOperationsHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + procedure DoOperationHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + public constructor Create(); - End; + end; TCalculator_ServiceBinderFactory = class(TInterfacedObject,IItemFactory) + private + FInstance : IInterface; protected function CreateInstance():IInterface; - End; + public + constructor Create(); + destructor Destroy();override; + end; procedure Server_service_RegisterCalculatorService(); @@ -34,9 +39,11 @@ Implementation uses TypInfo, wst_resources_imp,metadata_repository; { TCalculator_ServiceBinder implementation } -procedure TCalculator_ServiceBinder.AddIntHandler(AFormatter:IFormatterResponse); -Var +procedure TCalculator_ServiceBinder.AddIntHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; tmpObj : ICalculator; callCtx : ICallContext; strPrmName : string; @@ -44,34 +51,44 @@ Var A : Integer; B : Integer; returnVal : TBinaryArgsResult; -Begin - callCtx := GetCallContext(); - Pointer(returnVal) := Nil; +begin + callCtx := AContext; + TObject(returnVal) := nil; strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A); strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B); tmpObj := Self.GetFactory().CreateInstance() as ICalculator; if Supports(tmpObj,ICallControl,cllCntrl) then - cllCntrl.SetCallContext(GetCallContext()); - - returnVal := tmpObj.AddInt(A,B); - If Assigned(Pointer(returnVal)) Then - callCtx.AddObjectToFree(TObject(returnVal)); - - procName := AFormatter.GetCallProcedureName(); - trgName := AFormatter.GetCallTarget(); - AFormatter.Clear(); - AFormatter.BeginCallResponse(procName,trgName); - AFormatter.Put('return',TypeInfo(TBinaryArgsResult),returnVal); - AFormatter.EndCallResponse(); - - callCtx := Nil; -End; + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.AddInt(A,B); + if Assigned(TObject(returnVal)) then + callCtx.AddObjectToFree(TObject(returnVal)); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(TBinaryArgsResult),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; -procedure TCalculator_ServiceBinder.DivIntHandler(AFormatter:IFormatterResponse); -Var +procedure TCalculator_ServiceBinder.DivIntHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; tmpObj : ICalculator; callCtx : ICallContext; strPrmName : string; @@ -79,31 +96,41 @@ Var A : Integer; B : Integer; returnVal : Integer; -Begin - callCtx := GetCallContext(); +begin + callCtx := AContext; strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A); strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B); tmpObj := Self.GetFactory().CreateInstance() as ICalculator; if Supports(tmpObj,ICallControl,cllCntrl) then - cllCntrl.SetCallContext(GetCallContext()); - - returnVal := tmpObj.DivInt(A,B); - - procName := AFormatter.GetCallProcedureName(); - trgName := AFormatter.GetCallTarget(); - AFormatter.Clear(); - AFormatter.BeginCallResponse(procName,trgName); - AFormatter.Put('return',TypeInfo(Integer),returnVal); - AFormatter.EndCallResponse(); - - callCtx := Nil; -End; + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.DivInt(A,B); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(Integer),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; -procedure TCalculator_ServiceBinder.DoAllOperationsHandler(AFormatter:IFormatterResponse); -Var +procedure TCalculator_ServiceBinder.DoAllOperationsHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; tmpObj : ICalculator; callCtx : ICallContext; strPrmName : string; @@ -111,34 +138,44 @@ Var A : Integer; B : Integer; returnVal : TBinaryArgsResultArray; -Begin - callCtx := GetCallContext(); - Pointer(returnVal) := Nil; +begin + callCtx := AContext; + TObject(returnVal) := nil; strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A); strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B); tmpObj := Self.GetFactory().CreateInstance() as ICalculator; if Supports(tmpObj,ICallControl,cllCntrl) then - cllCntrl.SetCallContext(GetCallContext()); - - returnVal := tmpObj.DoAllOperations(A,B); - If Assigned(Pointer(returnVal)) Then - callCtx.AddObjectToFree(TObject(returnVal)); - - procName := AFormatter.GetCallProcedureName(); - trgName := AFormatter.GetCallTarget(); - AFormatter.Clear(); - AFormatter.BeginCallResponse(procName,trgName); - AFormatter.Put('return',TypeInfo(TBinaryArgsResultArray),returnVal); - AFormatter.EndCallResponse(); - - callCtx := Nil; -End; + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.DoAllOperations(A,B); + if Assigned(TObject(returnVal)) then + callCtx.AddObjectToFree(TObject(returnVal)); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(TBinaryArgsResultArray),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; -procedure TCalculator_ServiceBinder.DoOperationHandler(AFormatter:IFormatterResponse); -Var +procedure TCalculator_ServiceBinder.DoOperationHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; tmpObj : ICalculator; callCtx : ICallContext; strPrmName : string; @@ -147,9 +184,9 @@ Var B : Integer; AOperation : TCalc_Op; returnVal : TBinaryArgsResult; -Begin - callCtx := GetCallContext(); - Pointer(returnVal) := Nil; +begin + callCtx := AContext; + TObject(returnVal) := nil; strPrmName := 'A'; AFormatter.Get(TypeInfo(Integer),strPrmName,A); strPrmName := 'B'; AFormatter.Get(TypeInfo(Integer),strPrmName,B); @@ -157,38 +194,58 @@ Begin tmpObj := Self.GetFactory().CreateInstance() as ICalculator; if Supports(tmpObj,ICallControl,cllCntrl) then - cllCntrl.SetCallContext(GetCallContext()); - - returnVal := tmpObj.DoOperation(A,B,AOperation); - If Assigned(Pointer(returnVal)) Then - callCtx.AddObjectToFree(TObject(returnVal)); - - procName := AFormatter.GetCallProcedureName(); - trgName := AFormatter.GetCallTarget(); - AFormatter.Clear(); - AFormatter.BeginCallResponse(procName,trgName); - AFormatter.Put('return',TypeInfo(TBinaryArgsResult),returnVal); - AFormatter.EndCallResponse(); - - callCtx := Nil; -End; + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.DoOperation(A,B,AOperation); + if Assigned(TObject(returnVal)) then + callCtx.AddObjectToFree(TObject(returnVal)); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(TBinaryArgsResult),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; constructor TCalculator_ServiceBinder.Create(); -Begin - Inherited Create(GetServiceImplementationRegistry().FindFactory('ICalculator')); - RegisterVerbHandler('AddInt',@AddIntHandler); - RegisterVerbHandler('DivInt',@DivIntHandler); - RegisterVerbHandler('DoAllOperations',@DoAllOperationsHandler); - RegisterVerbHandler('DoOperation',@DoOperationHandler); -End; +begin + inherited Create(GetServiceImplementationRegistry().FindFactory('ICalculator')); + RegisterVerbHandler('AddInt',{$IFDEF FPC}@{$ENDIF}AddIntHandler); + RegisterVerbHandler('DivInt',{$IFDEF FPC}@{$ENDIF}DivIntHandler); + RegisterVerbHandler('DoAllOperations',{$IFDEF FPC}@{$ENDIF}DoAllOperationsHandler); + RegisterVerbHandler('DoOperation',{$IFDEF FPC}@{$ENDIF}DoOperationHandler); +end; { TCalculator_ServiceBinderFactory } + function TCalculator_ServiceBinderFactory.CreateInstance():IInterface; -Begin - Result := TCalculator_ServiceBinder.Create() as IInterface; -End; +begin + Result := FInstance; +end; + +constructor TCalculator_ServiceBinderFactory.Create(); +begin + FInstance := TCalculator_ServiceBinder.Create() as IInterface; +end; + +destructor TCalculator_ServiceBinderFactory.Destroy(); +begin + FInstance := nil; + inherited Destroy(); +end; procedure Server_service_RegisterCalculatorService(); @@ -198,10 +255,10 @@ End; initialization - {$IF DECLARED(Register_calculator_NameSpace)} - Register_calculator_NameSpace(); - {$ENDIF} - {$i calculator.wst} + {$IF DECLARED(Register_calculator_ServiceMetadata)} + Register_calculator_ServiceMetadata(); + {$IFEND} + End. diff --git a/wst/trunk/tests/calculator/srv/calculator_imp.pas b/wst/trunk/tests/calculator/srv/calculator_imp.pas index 9f4da2731..27e142931 100644 --- a/wst/trunk/tests/calculator/srv/calculator_imp.pas +++ b/wst/trunk/tests/calculator/srv/calculator_imp.pas @@ -2,10 +2,10 @@ This unit has been produced by ws_helper. Input unit name : "calculator". This unit name : "calculator_imp". - Date : "02/07/2006 16:49". + Date : "15/08/2007 16:34:20". } Unit calculator_imp; -{$mode objfpc}{$H+} +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} Interface Uses SysUtils, Classes, @@ -17,21 +17,21 @@ Type TCalculator_ServiceImp=class(TBaseServiceImplementation,ICalculator) Protected function AddInt( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):TBinaryArgsResult; function DivInt( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):Integer; function DoAllOperations( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):TBinaryArgsResultArray; function DoOperation( - Const A : Integer; - Const B : Integer; - Const AOperation : TCalc_Op + const A : Integer; + const B : Integer; + const AOperation : TCalc_Op ):TBinaryArgsResult; End; @@ -39,119 +39,47 @@ Type procedure RegisterCalculatorImplementationFactory(); Implementation +uses config_objects; { TCalculator_ServiceImp implementation } function TCalculator_ServiceImp.AddInt( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):TBinaryArgsResult; -var - hdr : TCalcResultHeader; - h : TCalcHeader; - cc : ICallContext; Begin - hdr := TCalcResultHeader.Create(); - cc := GetCallContext(); - if Assigned(cc) and ( cc.GetHeaderCount([hdIn]) > 0 ) and ( cc.GetHeader(0).InheritsFrom(TCalcHeader) ) then begin - h := cc.GetHeader(0) as TCalcHeader; - h.Understood := True; - hdr.Assign(h); - end; - hdr.TimeStamp := DateTimeToStr(Now()); - hdr.SessionID := 'testSession'; - cc.AddHeader(hdr,True); - hdr := nil; - Result := TBinaryArgsResult.Create(); - Try - Result.Arg_OP := '+'; - Result.Arg_OpEnum := coAdd; - Result.Arg_A := A; - Result.Arg_B := B; - Result.Arg_R := A + B; - Result.Comment := 'Doing an + operation'; - Except - FreeAndNil(Result); - Raise; - End; +// your code here End; function TCalculator_ServiceImp.DivInt( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):Integer; Begin - Result := A div B; +// your code here End; function TCalculator_ServiceImp.DoAllOperations( - Const A : Integer; - Const B : Integer + const A : Integer; + const B : Integer ):TBinaryArgsResultArray; Begin - Result := TBinaryArgsResultArray.Create(); - Result.SetLength(4); - With Result[0] do Begin - Arg_A := A; - Arg_B := B; - Arg_OP := '-'; - Arg_OpEnum := coSub; - Arg_R := Arg_A - Arg_B; - End; - With Result[1] do Begin - Arg_A := A; - Arg_B := B; - Arg_OP := '+'; - Arg_OpEnum := coAdd; - Arg_R := Arg_A + Arg_B; - End; - With Result[2] do Begin - Arg_A := A; - Arg_B := B; - Arg_OP := '*'; - Arg_OpEnum := coMul; - Arg_R := Arg_A * Arg_B; - End; - With Result[3] do Begin - Arg_A := A; - Arg_B := B; - Arg_OP := '/'; - Arg_OpEnum := coDiv; - Arg_R := Arg_A div Arg_B; - End; +// your code here End; function TCalculator_ServiceImp.DoOperation( - Const A : Integer; - Const B : Integer; - Const AOperation : TCalc_Op + const A : Integer; + const B : Integer; + const AOperation : TCalc_Op ):TBinaryArgsResult; Begin - Result := TBinaryArgsResult.Create(); - try - Result.Arg_A := A; - Result.Arg_B := B; - Result.Arg_OP := 'X'; - Result.Arg_OpEnum := AOperation; - Result.Comment := 'Doing an operation...'; - - case AOperation of - coAdd : Result.Arg_R := Result.Arg_A + Result.Arg_B; - coSub : Result.Arg_R := Result.Arg_A - Result.Arg_B; - coMul : Result.Arg_R := Result.Arg_A * Result.Arg_B; - coDiv : Result.Arg_R := Result.Arg_A div Result.Arg_B; - end; - except - FreeAndNil(Result); - raise; - end; +// your code here End; + + procedure RegisterCalculatorImplementationFactory(); Begin - GetServiceImplementationRegistry().Register( - 'ICalculator', - TImplementationFactory.Create(TCalculator_ServiceImp) as IServiceImplementationFactory - ).RegisterExtension(['TLoggerServiceExtension']); + GetServiceImplementationRegistry().Register('ICalculator',TImplementationFactory.Create(TCalculator_ServiceImp,wst_GetServiceConfigText('ICalculator')) as IServiceImplementationFactory); End; End. diff --git a/wst/trunk/tests/http_server/app_object.pas b/wst/trunk/tests/http_server/app_object.pas index b2443ab6d..22ddddf9b 100644 --- a/wst/trunk/tests/http_server/app_object.pas +++ b/wst/trunk/tests/http_server/app_object.pas @@ -64,9 +64,8 @@ uses base_service_intf, server_service_soap, server_binary_formatter, metadata_repository, metadata_wsdl, DOM, XMLWrite, calculator, calculator_binder, calculator_imp, - metadata_service, metadata_service_binder, metadata_service_imp, + metadata_service, metadata_service_binder, metadata_service_imp; - user_service_intf, user_service_intf_binder, user_service_intf_imp; const sSEPARATOR = '/'; diff --git a/wst/trunk/tests/http_server/wst_http_server.lpi b/wst/trunk/tests/http_server/wst_http_server.lpi index b5ab9e5fa..5379567fa 100644 --- a/wst/trunk/tests/http_server/wst_http_server.lpi +++ b/wst/trunk/tests/http_server/wst_http_server.lpi @@ -12,7 +12,7 @@ - + @@ -37,8 +37,8 @@ - - + + @@ -46,7 +46,7 @@ - + @@ -170,7 +170,7 @@ - + @@ -199,7 +199,7 @@ - + @@ -287,7 +287,7 @@ - + @@ -438,7 +438,7 @@ - + @@ -489,9 +489,9 @@ - - - + + + @@ -501,7 +501,7 @@ - + @@ -570,18 +570,14 @@ - - - - @@ -595,9 +591,7 @@ - - @@ -640,27 +634,15 @@ - + - - + + - - + + - - - - - - - - - - - - diff --git a/wst/trunk/tests/record/client/record_client.lpi b/wst/trunk/tests/record/client/record_client.lpi new file mode 100644 index 000000000..cdefb29aa --- /dev/null +++ b/wst/trunk/tests/record/client/record_client.lpi @@ -0,0 +1,222 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/record/client/record_client.pas b/wst/trunk/tests/record/client/record_client.pas new file mode 100644 index 000000000..66ebc31bd --- /dev/null +++ b/wst/trunk/tests/record/client/record_client.pas @@ -0,0 +1,110 @@ +program record_client; + +{$mode objfpc}{$H+} + +uses + Classes, SysUtils, {$IFDEF WINDOWS}ActiveX,{$ENDIF} + soap_formatter, + synapse_http_protocol, + //indy_http_protocol, + metadata_repository, + record_sample, record_sample_proxy; + +function ReadEntryStr(const APromp : string):string ; +begin + Result := ''; + Write(APromp); + while True do begin + ReadLn(Result); + Result := Trim(Result); + if ( Length(Result) > 0 ) then + Break; + end; +end; + +function ReadEntryInt(const APromp : string):Integer ; +var + locBuffer : string; +begin + Write(APromp); + while True do begin + ReadLn(locBuffer); + locBuffer := Trim(locBuffer); + if TryStrToInt(locBuffer,Result) then + Break; + end; +end; + +function ReadEntryFloat(const APromp : string) : Single ; +var + locBuffer : string; +begin + Write(APromp); + while True do begin + ReadLn(locBuffer); + locBuffer := Trim(locBuffer); + if TryStrToFloat(locBuffer,Result) then + Break; + end; +end; + +var + locService : RecordService; + A : RecordA; + B : RecordB; + C : RecordC; +begin +{$IFDEF WINDOWS} + CoInitialize(nil); + try +{$ENDIF} + SYNAPSE_RegisterHTTP_Transport(); + //INDY_RegisterHTTP_Transport(); + WriteLn('Web Services Toolkit Record sample'); + WriteLn('This sample demonstrates the Object Pascal "Record" support by WST'); + WriteLn(); + locService := TRecordService_Proxy.Create( + 'RecordService','soap:Style=RPC;EncodingStyle=Literal','http:address=http://127.0.0.1:20000/services/RecordService'); + while True do begin + A.fieldA := 0; + A.fieldB := 0; + C.intField := 1; + C.RecordField.RecordField.fieldA := 21; + C.RecordField.RecordField.fieldB := 22; + C.RecordField.RecordField.comment := 'Comment 23'; + C.RecordField.intField := 3; + C.RecordField.RecordField.comment := '31 comment'; + C.RecordField.comment := 'xx comment ddf'; + A.fieldA := ReadEntryInt('Enter the Integer field : '); + A.fieldB := ReadEntryFloat('Enter the Single field : '); + B.intField := 2 * A.fieldA; + B := locService.Add(A); + WriteLn; + WriteLn('Response ( B ) : '); + WriteLn(' intField : ',B.intField); + WriteLn(' singleField : ',B.singleField); + WriteLn(' comment : ',B.comment); + WriteLn(); + WriteLn; + C := locService.AddRec(A,B,C); + WriteLn; + WriteLn('Response ( C ) : '); + WriteLn(' intField : ',C.intField); + WriteLn(' RecordField.intField : ',C.RecordField.intField); + WriteLn(' RecordField.singleField : ',C.RecordField.singleField); + WriteLn(' RecordField.singleField : ',C.RecordField.comment); + WriteLn(' RecordField.RecordField.fieldA : ',C.RecordField.RecordField.fieldA); + WriteLn(' RecordField.RecordField.fieldB : ',C.RecordField.RecordField.fieldB); + WriteLn(' RecordField.RecordField.comment : ',C.RecordField.RecordField.comment); + WriteLn(); + + if ( UpperCase(ReadEntryStr('Continue ( Y/N ) :'))[1] <> 'Y' ) then + Break; + end; +{$IFDEF WINDOWS} + finally + CoUninitialize(); + end; +{$ENDIF} +end. + diff --git a/wst/trunk/tests/record/record_sample.WSDL b/wst/trunk/tests/record/record_sample.WSDL new file mode 100644 index 000000000..b71cb86ce --- /dev/null +++ b/wst/trunk/tests/record/record_sample.WSDL @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/record/record_sample.pas b/wst/trunk/tests/record/record_sample.pas new file mode 100644 index 000000000..1ad78aa21 --- /dev/null +++ b/wst/trunk/tests/record/record_sample.pas @@ -0,0 +1,146 @@ +{ +This unit has been produced by ws_helper. + Input unit name : "record_sample". + This unit name : "record_sample". + Date : "17/08/2007 19:37:26". +} +unit record_sample; +{$IFDEF FPC} + {$mode objfpc} {$H+} +{$ENDIF} +{$IFNDEF FPC} + {$DEFINE WST_RECORD_RTTI} +{$ENDIF} +interface + +uses SysUtils, Classes, TypInfo, base_service_intf, service_intf; + +const + sNAME_SPACE = 'record_sample'; + sUNIT_NAME = 'record_sample'; + +type + + + RecordA = record + fieldB : Single; + fieldA : Integer; + comment : String; + end; + + RecordB = record + singleField : Single; + intField : Integer; + comment : String; + RecordField : RecordA; + end; + + RecordC = record + intField : Integer; + RecordField : RecordB; + end; + + RecordService = interface(IInvokable) + ['{E42B7653-4B50-4956-88B4-FBCEC57B667A}'] + function Add( + const AValue : RecordA + ):RecordB; + function AddRec( + const AA : RecordA; + const AB : RecordB; + const AC : RecordC + ):RecordC; + end; + + procedure Register_record_sample_ServiceMetadata(); + +Implementation +uses metadata_repository, record_rtti, wst_types; + + +procedure Register_record_sample_ServiceMetadata(); +var + mm : IModuleMetadataMngr; +begin + mm := GetModuleMetadataMngr(); + mm.SetRepositoryNameSpace(sUNIT_NAME, sNAME_SPACE); +end; + + + +{$IFDEF WST_RECORD_RTTI} +function __RecordA_TYPEINFO_FUNC__() : PTypeInfo; +var + p : ^RecordA; + r : RecordA; +begin + p := @r; + Result := MakeRawTypeInfo( + 'RecordA', + SizeOf(RecordA), + [ PtrUInt(@(p^.fieldB)) - PtrUInt(p), PtrUInt(@(p^.fieldA)) - PtrUInt(p), PtrUInt(@(p^.comment)) - PtrUInt(p) ], + [ TypeInfo(Single), TypeInfo(Integer), TypeInfo(String) ] + ); +end; +{$ENDIF WST_RECORD_RTTI} + +{$IFDEF WST_RECORD_RTTI} +function __RecordB_TYPEINFO_FUNC__() : PTypeInfo; +var + p : ^RecordB; + r : RecordB; +begin + p := @r; + Result := MakeRawTypeInfo( + 'RecordB', + SizeOf(RecordB), + [ PtrUInt(@(p^.singleField)) - PtrUInt(p), PtrUInt(@(p^.intField)) - PtrUInt(p), PtrUInt(@(p^.comment)) - PtrUInt(p), PtrUInt(@(p^.RecordField)) - PtrUInt(p) ], + [ TypeInfo(Single), TypeInfo(Integer), TypeInfo(String), TypeInfo(RecordA) ] + ); +end; +{$ENDIF WST_RECORD_RTTI} + +{$IFDEF WST_RECORD_RTTI} +function __RecordC_TYPEINFO_FUNC__() : PTypeInfo; +var + p : ^RecordC; + r : RecordC; +begin + p := @r; + Result := MakeRawTypeInfo( + 'RecordC', + SizeOf(RecordC), + [ PtrUInt(@(p^.intField)) - PtrUInt(p), PtrUInt(@(p^.RecordField)) - PtrUInt(p) ], + [ TypeInfo(Integer), TypeInfo(RecordB) ] + ); +end; +{$ENDIF WST_RECORD_RTTI} +initialization + + + GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(RecordA),'RecordA').RegisterExternalPropertyName('__FIELDS__','fieldB;fieldA;comment'); +{$IFNDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordA)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(TypeInfo(RecordA)),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordA)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} +{$IFDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordA)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(__RecordA_TYPEINFO_FUNC__()),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordA)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} + + GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(RecordB),'RecordB').RegisterExternalPropertyName('__FIELDS__','singleField;intField;comment;RecordField'); +{$IFNDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordB)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(TypeInfo(RecordB)),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordB)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} +{$IFDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordB)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(__RecordB_TYPEINFO_FUNC__()),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordB)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} + + GetTypeRegistry().Register(sNAME_SPACE,TypeInfo(RecordC),'RecordC').RegisterExternalPropertyName('__FIELDS__','intField;RecordField'); +{$IFNDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordC)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(TypeInfo(RecordC)),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordC)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} +{$IFDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordC)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(__RecordC_TYPEINFO_FUNC__()),GetTypeRegistry().ItemByTypeInfo[TypeInfo(RecordC)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} + + +End. diff --git a/wst/trunk/tests/record/record_sample_binder.pas b/wst/trunk/tests/record/record_sample_binder.pas new file mode 100644 index 000000000..7dee77048 --- /dev/null +++ b/wst/trunk/tests/record/record_sample_binder.pas @@ -0,0 +1,165 @@ +{ +This unit has been produced by ws_helper. + Input unit name : "record_sample". + This unit name : "record_sample_binder". + Date : "17/08/2007 19:37:26". +} +unit record_sample_binder; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +interface + +uses SysUtils, Classes, base_service_intf, server_service_intf, record_sample; + +type + + + TRecordService_ServiceBinder = class(TBaseServiceBinder) + protected + procedure AddHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + procedure AddRecHandler(AFormatter : IFormatterResponse; AContext : ICallContext); + public + constructor Create(); + end; + + TRecordService_ServiceBinderFactory = class(TInterfacedObject,IItemFactory) + private + FInstance : IInterface; + protected + function CreateInstance():IInterface; + public + constructor Create(); + destructor Destroy();override; + end; + + procedure Server_service_RegisterRecordServiceService(); + +Implementation +uses TypInfo, wst_resources_imp,metadata_repository; + +{ TRecordService_ServiceBinder implementation } +procedure TRecordService_ServiceBinder.AddHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var + cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; + tmpObj : RecordService; + callCtx : ICallContext; + strPrmName : string; + procName,trgName : string; + AValue : RecordA; + returnVal : RecordB; +begin + callCtx := AContext; + + strPrmName := 'AValue'; AFormatter.Get(TypeInfo(RecordA),strPrmName,AValue); + + tmpObj := Self.GetFactory().CreateInstance() as RecordService; + if Supports(tmpObj,ICallControl,cllCntrl) then + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.Add(AValue); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(RecordB),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; + +procedure TRecordService_ServiceBinder.AddRecHandler(AFormatter : IFormatterResponse; AContext : ICallContext); +var + cllCntrl : ICallControl; + objCntrl : IObjectControl; + hasObjCntrl : Boolean; + tmpObj : RecordService; + callCtx : ICallContext; + strPrmName : string; + procName,trgName : string; + AA : RecordA; + AB : RecordB; + AC : RecordC; + returnVal : RecordC; +begin + callCtx := AContext; + + strPrmName := 'AA'; AFormatter.Get(TypeInfo(RecordA),strPrmName,AA); + strPrmName := 'AB'; AFormatter.Get(TypeInfo(RecordB),strPrmName,AB); + strPrmName := 'AC'; AFormatter.Get(TypeInfo(RecordC),strPrmName,AC); + + tmpObj := Self.GetFactory().CreateInstance() as RecordService; + if Supports(tmpObj,ICallControl,cllCntrl) then + cllCntrl.SetCallContext(callCtx); + hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl); + if hasObjCntrl then + objCntrl.Activate(); + try + returnVal := tmpObj.AddRec(AA,AB,AC); + + procName := AFormatter.GetCallProcedureName(); + trgName := AFormatter.GetCallTarget(); + AFormatter.Clear(); + AFormatter.BeginCallResponse(procName,trgName); + AFormatter.Put('Result',TypeInfo(RecordC),returnVal); + AFormatter.EndCallResponse(); + + callCtx := nil; + finally + if hasObjCntrl then + objCntrl.Deactivate(); + Self.GetFactory().ReleaseInstance(tmpObj); + end; +end; + + +constructor TRecordService_ServiceBinder.Create(); +begin + inherited Create(GetServiceImplementationRegistry().FindFactory('RecordService')); + RegisterVerbHandler('Add',{$IFDEF FPC}@{$ENDIF}AddHandler); + RegisterVerbHandler('AddRec',{$IFDEF FPC}@{$ENDIF}AddRecHandler); +end; + + +{ TRecordService_ServiceBinderFactory } + +function TRecordService_ServiceBinderFactory.CreateInstance():IInterface; +begin + Result := FInstance; +end; + +constructor TRecordService_ServiceBinderFactory.Create(); +begin + FInstance := TRecordService_ServiceBinder.Create() as IInterface; +end; + +destructor TRecordService_ServiceBinderFactory.Destroy(); +begin + FInstance := nil; + inherited Destroy(); +end; + + +procedure Server_service_RegisterRecordServiceService(); +Begin + GetServerServiceRegistry().Register('RecordService',TRecordService_ServiceBinderFactory.Create() as IItemFactory); +End; + +initialization + + {$i record_sample.wst} + + {$IF DECLARED(Register_record_sample_ServiceMetadata)} + Register_record_sample_ServiceMetadata(); + {$IFEND} + +End. diff --git a/wst/trunk/tests/record/record_sample_imp.pas b/wst/trunk/tests/record/record_sample_imp.pas new file mode 100644 index 000000000..9e6066421 --- /dev/null +++ b/wst/trunk/tests/record/record_sample_imp.pas @@ -0,0 +1,67 @@ +{ +This unit has been produced by ws_helper. + Input unit name : "record_sample". + This unit name : "record_sample_imp". + Date : "17/08/2007 19:37:26". +} +Unit record_sample_imp; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +Interface + +Uses SysUtils, Classes, + base_service_intf, server_service_intf, server_service_imputils, record_sample; + +Type + + + TRecordService_ServiceImp=class(TBaseServiceImplementation,RecordService) + Protected + function Add( + const AValue : RecordA + ):RecordB; + function AddRec( + const AA : RecordA; + const AB : RecordB; + const AC : RecordC + ):RecordC; + End; + + + procedure RegisterRecordServiceImplementationFactory(); + +Implementation +uses config_objects; + +{ TRecordService_ServiceImp implementation } +function TRecordService_ServiceImp.Add( + const AValue : RecordA +):RecordB; +Begin + Result.singleField := AValue.fieldA + AValue.fieldB; + Result.intField := Trunc(AValue.fieldA + AValue.fieldB); + Result.comment := 'Computed in Add().'; + Result.RecordField := AValue; +End; + +function TRecordService_ServiceImp.AddRec( + const AA : RecordA; + const AB : RecordB; + const AC : RecordC +):RecordC; +Begin + Result.RecordField.intField := 1234; + Result.RecordField.RecordField.fieldA := 0; + Result.RecordField.RecordField.fieldB := 0; + Result.intField := Trunc(AA.fieldA + AA.fieldB); + Result.RecordField.singleField := AB.singleField + AB.intField; + Result.RecordField.comment := 'Computed in AddRec().'; +End; + + + +procedure RegisterRecordServiceImplementationFactory(); +Begin + GetServiceImplementationRegistry().Register('RecordService',TImplementationFactory.Create(TRecordService_ServiceImp,wst_GetServiceConfigText('RecordService')) as IServiceImplementationFactory); +End; + +End. diff --git a/wst/trunk/tests/record/record_sample_proxy.pas b/wst/trunk/tests/record/record_sample_proxy.pas new file mode 100644 index 000000000..cbb34c5b5 --- /dev/null +++ b/wst/trunk/tests/record/record_sample_proxy.pas @@ -0,0 +1,107 @@ +{ +This unit has been produced by ws_helper. + Input unit name : "record_sample". + This unit name : "record_sample_proxy". + Date : "17/08/2007 19:37:26". +} + +Unit record_sample_proxy; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +Interface + +Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, record_sample; + +Type + + + TRecordService_Proxy=class(TBaseProxy,RecordService) + Protected + class function GetServiceType() : PTypeInfo;override; + function Add( + const AValue : RecordA + ):RecordB; + function AddRec( + const AA : RecordA; + const AB : RecordB; + const AC : RecordC + ):RecordC; + End; + + Function wst_CreateInstance_RecordService(const AFormat : string = 'SOAP:'; const ATransport : string = 'HTTP:'):RecordService; + +Implementation +uses wst_resources_imp, metadata_repository; + + +Function wst_CreateInstance_RecordService(const AFormat : string; const ATransport : string):RecordService; +Begin + Result := TRecordService_Proxy.Create('RecordService',AFormat+GetServiceDefaultFormatProperties(TypeInfo(RecordService)),ATransport + 'address=' + GetServiceDefaultAddress(TypeInfo(RecordService))); +End; + +{ TRecordService_Proxy implementation } + +class function TRecordService_Proxy.GetServiceType() : PTypeInfo; +begin + result := TypeInfo(RecordService); +end; + +function TRecordService_Proxy.Add( + const AValue : RecordA +):RecordB; +Var + locSerializer : IFormatterClient; + strPrmName : string; +Begin + locSerializer := GetSerializer(); + Try + locSerializer.BeginCall('Add', GetTarget(),(Self as ICallContext)); + locSerializer.Put('AValue', TypeInfo(RecordA), AValue); + locSerializer.EndCall(); + + MakeCall(); + + locSerializer.BeginCallRead((Self as ICallContext)); + strPrmName := 'Result'; + locSerializer.Get(TypeInfo(RecordB), strPrmName, Result); + + Finally + locSerializer.Clear(); + End; +End; + +function TRecordService_Proxy.AddRec( + const AA : RecordA; + const AB : RecordB; + const AC : RecordC +):RecordC; +Var + locSerializer : IFormatterClient; + strPrmName : string; +Begin + locSerializer := GetSerializer(); + Try + locSerializer.BeginCall('AddRec', GetTarget(),(Self as ICallContext)); + locSerializer.Put('AA', TypeInfo(RecordA), AA); + locSerializer.Put('AB', TypeInfo(RecordB), AB); + locSerializer.Put('AC', TypeInfo(RecordC), AC); + locSerializer.EndCall(); + + MakeCall(); + + locSerializer.BeginCallRead((Self as ICallContext)); + strPrmName := 'Result'; + locSerializer.Get(TypeInfo(RecordC), strPrmName, Result); + + Finally + locSerializer.Clear(); + End; +End; + + +initialization + {$i record_sample.wst} + + {$IF DECLARED(Register_record_sample_ServiceMetadata)} + Register_record_sample_ServiceMetadata(); + {$IFEND} +End. diff --git a/wst/trunk/tests/record/server/delphi/record_server.cfg b/wst/trunk/tests/record/server/delphi/record_server.cfg new file mode 100644 index 000000000..7cb1cce24 --- /dev/null +++ b/wst/trunk/tests/record/server/delphi/record_server.cfg @@ -0,0 +1,44 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-N"obj" +-LE"c:\program files\borland\delphi7\Projects\Bpl" +-LN"c:\program files\borland\delphi7\Projects\Bpl" +-U"..\..\..\;..\..\;..\;..\..\..\..\" +-O"..\..\..\;..\..\;..\;..\..\..\..\" +-I"..\..\..\;..\..\;..\;..\..\..\..\" +-R"..\..\..\;..\..\;..\;..\..\..\..\" +-DINDY_9 +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/wst/trunk/tests/record/server/delphi/record_server.dof b/wst/trunk/tests/record/server/delphi/record_server.dof new file mode 100644 index 000000000..987b751eb --- /dev/null +++ b/wst/trunk/tests/record/server/delphi/record_server.dof @@ -0,0 +1,159 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir=obj +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=..\..\..\;..\..\;..\;..\..\..\..\ +Packages=vcl;rtl;vclx;indy;inet;xmlrtl;vclie;inetdbbde;inetdbxpress;dbrtl;dsnap;dsnapcon;vcldb;soaprtl;VclSmp;dbexpress;dbxcds;inetdb;bdertl;vcldbx;webdsnap;websnap;adortl;ibxpress;teeui;teedb;tee;dss;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOfficeXP;FIBDBMidas7;Jcl;JclVcl;JvCoreD7R;JvSystemD7R;JvStdCtrlsD7R;JvAppFrmD7R;JvBandsD7R;JvDBD7R;JvDlgsD7R;JvBDED7R;JvCmpD7R;JvCryptD7R;JvCtrlsD7R;JvCustomD7R;JvDockingD7R;JvDotNetCtrlsD7R;JvEDID7R;JvGlobusD7R;JvHMID7R;JvInterpreterD7R;JvJansD7R;JvManagedThreadsD7R;JvMMD7R;JvNetD7R;JvPageCompsD7R;JvPluginD7R;JvPrintPreviewD7R;JvRuntimeDesignD7R;JvTimeFrameworkD7R;JvUIBD7R;JvValidatorsD7R;JvWizardD7R;JvXPCtrlsD7R;dxForumLibD7;cxLibraryVCLD7;cxPageControlVCLD7;dxBarD7;dxComnD7;dxBarDBNavD7;dxBarExtItemsD7;dxBarExtDBItemsD7;dxsbD7;dxmdsD7;dxdbtrD7;dxtrmdD7;dxorgcD7;dxdborD7;dxEdtrD7;EQTLD7;ECQDBCD7;EQDBTLD7;EQGridD7;dxGrEdD7;dxExELD7;dxELibD7;cxEditorsVCLD7;cxGridVCLD7;dxThemeD7;cxDataD7;cxGridUtilsVCLD7;dxPSCoreD7;dxPsPrVwAdvD7;dxPSLnksD7;dxPSTeeChartD7;dxPSDBTeeChartD7;dxPSdxDBTVLnkD7;dxPSdxOCLnkD7;dxPSdxDBOCLnkD7;dxPScxGridLnkD7;dxPSTLLnkD7;qrpt +Conditionals=INDY_9 +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir=C:\Program Files\Borland\Delphi7\Bin\ +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1036 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= +[Excluded Packages] +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxDBTLLnkD7.bpl=ExpressPrinting System ReportLink for ExpressQuantumDBTreeList by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxDBGrLnkD7.bpl=ExpressPrinting System ReportLink for ExpressQuantumGrid by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxInsLnkD7.bpl=ExpressPrinting System ReportLink for ExpressInspector by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxOILnkD7.bpl=ExpressPrinting System ReportLink for ExpressRTTIInspector by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxMVLnkD7.bpl=ExpressPrinting System ReportLink for ExpressMasterView by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPSdxFCLnkD7.bpl=ExpressPrinting System ReportLinks for ExpressFlowChart by Developer Express Inc. +C:\Program Files\Developer Express Inc\ExpressPrinting System\Delphi 7\Lib\dxPScxSSLnkD7.bpl=ExpressPrinting System ReportLink for ExpressSpreadSheet by Developer Express Inc. +[HistoryLists\hlConditionals] +Count=1 +Item0=INDY_9 +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[HistoryLists\hlSearchPath] +Count=4 +Item0=..\..\..\;..\..\;..\;..\..\..\..\ +Item1=$(DELPHI)\Lib\Debug;C:\PROGRA~1\Borland\Delphi7\MyTools\JVCL\3.20\jcl\lib\d7\debug;..\..\..\;..\..\;..\;..\..\..\..\ +Item2=..\..\..\;..\..\;..\ +Item3=..\ +[HistoryLists\hlUnitOutputDirectory] +Count=1 +Item0=obj diff --git a/wst/trunk/tests/record/server/delphi/record_server.dpr b/wst/trunk/tests/record/server/delphi/record_server.dpr new file mode 100644 index 000000000..953b405ab --- /dev/null +++ b/wst/trunk/tests/record/server/delphi/record_server.dpr @@ -0,0 +1,44 @@ +program record_server; + +{$APPTYPE CONSOLE} + +uses + delphi_init_com, Classes, SysUtils, + indy_http_server, + metadata_service, + server_listener, + server_service_soap, + server_binary_formatter, + server_service_xmlrpc, + config_objects, + record_sample, + record_sample_binder, + record_sample_imp, + record_rtti; + +var + AppObject : TwstListener; +begin + Server_service_RegisterBinaryFormat(); + Server_service_RegisterSoapFormat(); + Server_service_RegisterXmlRpcFormat(); + + RegisterRecordServiceImplementationFactory(); + Server_service_RegisterRecordServiceService(); + + //wst_CreateDefaultFile(wst_GetConfigFileName(),nil); + + AppObject := TwstIndyHttpListener.Create('127.0.0.1',20000); + try + WriteLn('"Web Service Toolkit" HTTP Server sample listening at:'); + WriteLn(''); + WriteLn('http://127.0.0.1:20000/'); + WriteLn(''); + WriteLn('Press enter to quit.'); + AppObject.Start(); + ReadLn; + finally + FreeAndNil(AppObject); + end; +end. + diff --git a/wst/trunk/tests/record/server/record_server.lpi b/wst/trunk/tests/record/server/record_server.lpi new file mode 100644 index 000000000..687f9f060 --- /dev/null +++ b/wst/trunk/tests/record/server/record_server.lpi @@ -0,0 +1,240 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/record/server/record_server.pas b/wst/trunk/tests/record/server/record_server.pas new file mode 100644 index 000000000..3cf0387e8 --- /dev/null +++ b/wst/trunk/tests/record/server/record_server.pas @@ -0,0 +1,40 @@ +program record_server; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, SysUtils, + indy_http_server, metadata_service, server_listener, + server_service_soap, server_binary_formatter, server_service_xmlrpc, config_objects, + record_sample, record_sample_binder, record_sample_imp, record_rtti; + + +var + AppObject : TwstListener; +begin + Server_service_RegisterBinaryFormat(); + Server_service_RegisterSoapFormat(); + Server_service_RegisterXmlRpcFormat(); + + RegisterRecordServiceImplementationFactory(); + Server_service_RegisterRecordServiceService(); + + //wst_CreateDefaultFile(wst_GetConfigFileName(),nil); + + AppObject := TwstIndyHttpListener.Create('127.0.0.1',20000); + try + WriteLn('"Web Service Toolkit" HTTP Server sample listening at:'); + WriteLn(''); + WriteLn('http://127.0.0.1:20000/'); + WriteLn(''); + WriteLn('Press enter to quit.'); + AppObject.Start(); + ReadLn(); + finally + FreeAndNil(AppObject); + end; +end. + diff --git a/wst/trunk/tests/record/test/test_record.lpi b/wst/trunk/tests/record/test/test_record.lpi new file mode 100644 index 000000000..66ff8fe50 --- /dev/null +++ b/wst/trunk/tests/record/test/test_record.lpi @@ -0,0 +1,305 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/tests/record/test/test_record.pas b/wst/trunk/tests/record/test/test_record.pas new file mode 100644 index 000000000..574729194 --- /dev/null +++ b/wst/trunk/tests/record/test/test_record.pas @@ -0,0 +1,47 @@ +program test_record; + +{$mode objfpc}{$H+} + +uses + Classes, SysUtils + ,TypInfo, record_rtti; + +type + + TSampleRecord = record + fieldA : Integer; + fieldB : Single; + end; + +procedure PrintRecType(ARecTyp : PRecordTypeData); +var + i : Integer; + f : TRecordFieldInfo; +begin + Assert(Assigned(ARecTyp)); + WriteLn(''); + WriteLn('Type name = ', ARecTyp^.Name); + WriteLn(' RecordSize = ', ARecTyp^.RecordSize); + WriteLn(' FieldCount = ', ARecTyp^.FieldCount); + for i := 1 to ARecTyp^.FieldCount do begin + f := ARecTyp^.Fields[i-1]; + WriteLn(' Field[',i,']'); + WriteLn(' Name = ',f.Name); + WriteLn(' Offset = ',f.Offset); + WriteLn(' TypeInfo = ',PtrUInt(f.TypeInfo)); + if ( f.TypeInfo <> nil ) then begin + WriteLn(' TypeInfo^.Name = ',f.TypeInfo^^.Name); + end; + end; + WriteLn(''); +end; + +var + recTyp : PRecordTypeData; +begin + recTyp := MakeRecordTypeInfo(TypeInfo(TSampleRecord)); + PrintRecType(recTyp); + FreeRecordTypeInfo(recTyp); + ReadLn; +end. + diff --git a/wst/trunk/tests/test_suite/delphi/wst_test_suite.cfg b/wst/trunk/tests/test_suite/delphi/wst_test_suite.cfg index eeed8992b..838505cf5 100644 --- a/wst/trunk/tests/test_suite/delphi/wst_test_suite.cfg +++ b/wst/trunk/tests/test_suite/delphi/wst_test_suite.cfg @@ -15,7 +15,7 @@ -$O+ -$P+ -$Q- --$R- +-$R+ -$S- -$T- -$U- diff --git a/wst/trunk/tests/test_suite/delphi/wst_test_suite.dof b/wst/trunk/tests/test_suite/delphi/wst_test_suite.dof index 32e0ed555..5987f7b5f 100644 --- a/wst/trunk/tests/test_suite/delphi/wst_test_suite.dof +++ b/wst/trunk/tests/test_suite/delphi/wst_test_suite.dof @@ -18,7 +18,7 @@ N=1 O=1 P=1 Q=0 -R=0 +R=1 S=0 T=0 U=0 diff --git a/wst/trunk/tests/test_suite/simple_record_test.pas b/wst/trunk/tests/test_suite/simple_record_test.pas new file mode 100644 index 000000000..1d65434c7 --- /dev/null +++ b/wst/trunk/tests/test_suite/simple_record_test.pas @@ -0,0 +1,39 @@ +{$DEFINE HAS_QWORD} +{$DEFINE HAS_COMP} + +unit simple_record_test; +interface + +type + TTestSmallRecord = record + fieldSmallint : Smallint; + fieldWord : Word; + fieldString : string; + end; + + TTestRecord = record + fieldByte : Byte; + fieldShortInt : ShortInt; + fieldSmallint : Smallint; + fieldWord : Word; + fieldInteget : Integer; + fieldLongWord : LongWord; + fieldInt64 : Int64; + {$IFDEF HAS_QWORD} + fieldQWord : QWord; + {$ENDIF} + {$IFDEF HAS_COMP} + fieldComp : Comp; + {$ENDIF} + fieldSingle : Single; + fieldDouble : Double; + fieldExtended : Extended; + fieldCurrency : Currency; + fieldBoolean : Boolean; + fieldString : string; + fieldRecord : TTestSmallRecord; + end; + +implementation + +end. \ No newline at end of file diff --git a/wst/trunk/tests/test_suite/test_utilities.pas b/wst/trunk/tests/test_suite/test_utilities.pas index 3f0f9a23b..e4474bdf2 100644 --- a/wst/trunk/tests/test_suite/test_utilities.pas +++ b/wst/trunk/tests/test_suite/test_utilities.pas @@ -13,9 +13,6 @@ uses TypInfo, base_service_intf, server_service_intf; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - type ITest = interface @@ -37,7 +34,35 @@ type constructor Create();override; end; + ISimple_A = interface + ['{D015AD95-6062-4650-9B00-CF3004E9CA1A}']//['{4793180A-DAA4-4E50-9194-5EEEE851EBE3}'] + end; + ISimple_B = interface + ['{4793180A-DAA4-4E50-9194-5EEEE851EBE3}'] + end; + + TSimpleFactoryItem_A = class(TSimpleFactoryItem,IInterface,ISimple_A) + end; + + TSimpleFactoryItem_B = class(TSimpleFactoryItem,IInterface,ISimple_B) + end; + + { TTest_TIntfPoolItem } + + TTest_TIntfPoolItem = class(TTestCase) + published + procedure All(); + end; + + { TTest_TSimpleItemFactory } + + TTest_TSimpleItemFactory = class(TTestCase) + published + procedure CreateProc(); + procedure CreateInstance(); + end; + { TTest_TIntfPool } TTest_TIntfPool= class(TTestCase) @@ -447,15 +472,121 @@ begin Check(oldElt <> elt,'4.2'); end; +{ TTest_TIntfPoolItem } + +procedure TTest_TIntfPoolItem.All(); +var + i : IInterface; + b : Boolean; + a : TIntfPoolItem; +begin + i := nil; + b := False; + a := TIntfPoolItem.Create(i,b); + try + Check(( i = a.Intf ),'Create() > Intf'); + CheckEquals(b,a.Used,'Create() > Used'); + b := not b; + a.Used := b; + CheckEquals(b,a.Used,'Used'); + finally + FreeAndNil(a); + end; + a := nil; + + i := nil; + b := True; + a := TIntfPoolItem.Create(i,b); + try + Check(( i = a.Intf ),'Create() > Intf'); + CheckEquals(b,a.Used,'Create() > Used'); + b := not b; + a.Used := b; + CheckEquals(b,a.Used,'Used'); + finally + FreeAndNil(a); + end; +end; + +{ TTest_TSimpleItemFactory } + +procedure TTest_TSimpleItemFactory.CreateInstance(); +var + b, a : IItemFactory; + itm : IInterface; +begin + a := TSimpleItemFactory.Create(TSimpleFactoryItem_A); + itm := a.CreateInstance(); + CheckEquals(True,Assigned(itm)); + CheckEquals(True,Supports(itm,ISimple_A)); + + itm := a.CreateInstance(); + CheckEquals(True,Assigned(itm)); + CheckEquals(True,Supports(itm,ISimple_A)); + + b := TSimpleItemFactory.Create(TSimpleFactoryItem_B); + itm := b.CreateInstance(); + CheckEquals(True,Assigned(itm)); + CheckEquals(True,Supports(itm,ISimple_B)); + + itm := b.CreateInstance(); + CheckEquals(True,Assigned(itm)); + CheckEquals(True,Supports(itm,ISimple_B)); +end; + +type + + { TSimpleItemFactoryCrack } + + TSimpleItemFactoryCrack = class(TSimpleItemFactory) + public + function GetItemClass() : TSimpleFactoryItemClass; + end; + +{ TSimpleItemFactoryCrack } + +function TSimpleItemFactoryCrack.GetItemClass() : TSimpleFactoryItemClass; +begin + Result := inherited GetItemClass(); +end; + +procedure TTest_TSimpleItemFactory.CreateProc(); +var + a : IItemFactory; + b : TSimpleItemFactoryCrack; + ok : Boolean; +begin + ok := False; + try + TSimpleItemFactory.Create(nil); + except + on e : EServiceConfigException do begin + ok := True; + end; + end; + CheckEquals(True,ok,'Create(nil)'); + + b := TSimpleItemFactoryCrack.Create(TSimpleFactoryItem_A); + CheckEquals(TSimpleFactoryItem_A,b.GetItemClass()); + FreeAndNil(b); + + b := TSimpleItemFactoryCrack.Create(TSimpleFactoryItem_B); + CheckEquals(TSimpleFactoryItem_B,b.GetItemClass()); +end; + initialization {$IFDEF FPC} RegisterTest(TTest_TIntfPool); RegisterTest(TTest_TSimpleItemFactoryEx); RegisterTest(TTest_TImplementationFactory); + RegisterTest(TTest_TIntfPoolItem); + RegisterTest(TTest_TImplementationFactory); {$ELSE} RegisterTest(TTest_TIntfPool.Suite); RegisterTest(TTest_TSimpleItemFactoryEx.Suite); RegisterTest(TTest_TImplementationFactory.Suite); + RegisterTest(TTest_TIntfPoolItem.Suite); + RegisterTest(TTest_TImplementationFactory.Suite); {$ENDIF} end. diff --git a/wst/trunk/tests/test_suite/testformatter_unit.pas b/wst/trunk/tests/test_suite/testformatter_unit.pas index af834a116..e5cc69d42 100644 --- a/wst/trunk/tests/test_suite/testformatter_unit.pas +++ b/wst/trunk/tests/test_suite/testformatter_unit.pas @@ -19,14 +19,12 @@ uses Classes, SysUtils, {$IFDEF FPC} fpcunit, testutils, testregistry, -{$ELSE} - TestFrameWork, +{$ENDIF} +{$IFNDEF FPC} + TestFrameWork, ActiveX, {$ENDIF} TypInfo, - base_service_intf; - -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} + base_service_intf, wst_types, server_service_intf, service_intf; type @@ -285,6 +283,31 @@ type TEmbeddedArrayOfStringRemotable = class(TArrayOfStringRemotable); + TTestSmallRecord = record + fieldSmallint : Smallint; + fieldWord : Word; + fieldString : string; + end; + + TTestRecord = record + fieldByte : Byte; + fieldShortInt : ShortInt; + fieldSmallint : Smallint; + fieldWord : Word; + fieldInteger : Integer; + fieldLongWord : LongWord; + fieldInt64 : Int64; + fieldQWord : QWord; + fieldComp : Comp; + fieldSingle : Single; + fieldDouble : Double; + fieldExtended : Extended; + fieldCurrency : Currency; + fieldBoolean : Boolean; + fieldString : string; + fieldRecord : TTestSmallRecord; + end; + { TTestFormatterSimpleType } TTestFormatterSimpleType= class(TTestCase) @@ -352,6 +375,9 @@ type procedure Test_FloatCurrencyArray(); procedure Test_ComplexInt32S(); + + procedure Test_Record_simple(); + procedure Test_Record_nested(); end; { TTestBinaryFormatter } @@ -452,8 +478,43 @@ type procedure ParseDate(); end; + { TTest_SoapFormatterExceptionBlock } + + TTest_SoapFormatterExceptionBlock = class(TTestCase) + protected + procedure SetUp(); override; + procedure TearDown(); override; + function CreateFormatter():IFormatterResponse; + function CreateFormatterClient():IFormatterClient; + published + procedure ExceptBlock_server(); + procedure ExceptBlock_client(); + end; + + { TTest_XmlRpcFormatterExceptionBlock } + + TTest_XmlRpcFormatterExceptionBlock = class(TTestCase) + protected + procedure SetUp(); override; + procedure TearDown(); override; + 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; +uses base_binary_formatter, base_soap_formatter, base_xmlrpc_formatter, record_rtti, + Math, imp_utils +{$IFNDEF FPC} + , xmldom, wst_delphi_xml +{$ENDIF} +{$IFDEF FPC} + , DOM, XMLRead, wst_fpc_xml +{$ENDIF} + , server_service_soap, soap_formatter, + server_service_xmlrpc, xmlrpc_formatter; function TTestFormatterSimpleType.Support_ComplextType_with_SimpleContent( ): Boolean; begin @@ -2502,6 +2563,139 @@ begin end; end; +procedure TTestFormatter.Test_Record_simple(); +const VAL_1 : Integer = 12; VAL_2 : Integer = -76; VAL_3 = 'wst record sample'; +var + f : IFormatterBase; + s : TMemoryStream; + x : string; + a : TTestSmallRecord; +begin + s := nil; + try + a.fieldWord := VAL_1; + a.fieldSmallint := VAL_2; + a.fieldString := VAL_3; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('a',TypeInfo(TTestSmallRecord),a); + f.EndScope(); + a.fieldWord := 0; + a.fieldSmallint := 0; + a.fieldString := ''; + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.Test_Record_simple.xml'); + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginObjectRead(x,TypeInfo(TClass_Int)); + x := 'a'; + f.Get(TypeInfo(TTestSmallRecord),x,a); + f.EndScopeRead(); + + CheckEquals(VAL_1,a.fieldWord); + CheckEquals(VAL_2,a.fieldSmallint); + CheckEquals(VAL_3,a.fieldString); + finally + s.Free(); + end; +end; + +procedure TTestFormatter.Test_Record_nested(); +const + VAL_EPSILON = 0.0001; + VAL_EMPTY_RECORD : TTestRecord = ( + fieldByte : 0; + fieldShortInt : 0; + fieldSmallint : 0; + fieldWord : 0; + fieldInteger : 0; + fieldLongWord : 0; + fieldInt64 : 0; + fieldQWord : 0; + fieldComp : 0; + fieldSingle : 0; + fieldDouble : 0; + fieldExtended : 0; + fieldCurrency : 0; + fieldBoolean : False; + fieldString : ''; + fieldRecord : ( fieldSmallint : 0; fieldWord : 0; fieldString : ''); + ); + VAL_RECORD : TTestRecord = ( + fieldByte : 12; + fieldShortInt : -10; + fieldSmallint : 76; + fieldWord : 34; + fieldInteger : -45; + fieldLongWord : 567; + fieldInt64 : 8910; + fieldQWord : 111213; + fieldComp : 141516; + fieldSingle : 1718; + fieldDouble : -1819; + fieldExtended : 2021; + fieldCurrency : -2122; + fieldBoolean : True; + fieldString : 'sample record string 0123456789'; + fieldRecord : ( fieldSmallint : 10; fieldWord : 11; fieldString : 'azertyqwerty'); + ); +var + f : IFormatterBase; + s : TMemoryStream; + x : string; + a : TTestRecord; +begin + s := nil; + try + a := VAL_RECORD; + f := CreateFormatter(TypeInfo(TClass_Int)); + + f.BeginObject('Root',TypeInfo(TClass_Int)); + f.Put('a',TypeInfo(TTestRecord),a); + f.EndScope(); + a := VAL_EMPTY_RECORD; + s := TMemoryStream.Create(); + f.SaveToStream(s); s.SaveToFile(ClassName + '.Test_Record_nested.xml'); + + f := CreateFormatter(TypeInfo(TClass_Int)); + s.Position := 0; + f.LoadFromStream(s); + x := 'Root'; + f.BeginObjectRead(x,TypeInfo(TClass_Int)); + x := 'a'; + f.Get(TypeInfo(TTestRecord),x,a); + f.EndScopeRead(); + + CheckEquals(VAL_RECORD.fieldBoolean,a.fieldBoolean,'fieldBoolean'); + CheckEquals(VAL_RECORD.fieldByte,a.fieldByte,'fieldByte'); +{$IFDEF HAS_COMP} + CheckEquals(VAL_RECORD.fieldComp,a.fieldComp,'fieldComp'); +{$ENDIF} + Check(IsZero(VAL_RECORD.fieldCurrency-a.fieldCurrency,VAL_EPSILON),'fieldCurrency'); + Check(IsZero(VAL_RECORD.fieldExtended-a.fieldExtended,VAL_EPSILON),'fieldExtended'); + CheckEquals(VAL_RECORD.fieldInt64,a.fieldInt64,'fieldInt64'); + CheckEquals(VAL_RECORD.fieldInteger,a.fieldInteger,'fieldInteger'); + Check(VAL_RECORD.fieldLongWord = a.fieldLongWord,'fieldLongWord'); +{$IFDEF HAS_QWORD} + CheckEquals(VAL_RECORD.fieldQWord,a.fieldQWord,'fieldQWord'); +{$ENDIF} + CheckEquals(VAL_RECORD.fieldRecord.fieldSmallint,a.fieldRecord.fieldSmallint,'fieldSmallint'); + CheckEquals(VAL_RECORD.fieldRecord.fieldString,a.fieldRecord.fieldString,'fieldString'); + CheckEquals(VAL_RECORD.fieldRecord.fieldWord,a.fieldRecord.fieldWord,'fieldWord'); + CheckEquals(VAL_RECORD.fieldShortInt,a.fieldShortInt,'fieldShortInt'); + Check(IsZero(VAL_RECORD.fieldSingle-a.fieldSingle,VAL_EPSILON),'fieldSingle'); + CheckEquals(VAL_RECORD.fieldSmallint,a.fieldSmallint,'fieldSmallint'); + CheckEquals(VAL_RECORD.fieldString,a.fieldString,'fieldString'); + CheckEquals(VAL_RECORD.fieldWord,a.fieldWord,'fieldWord'); + finally + s.Free(); + end; +end; + { TTestBinaryFormatter } @@ -3151,6 +3345,386 @@ begin Result := False; end; +{ TTest_SoapFormatterExceptionBlock } + +function TTest_SoapFormatterExceptionBlock.CreateFormatter() : IFormatterResponse; +begin + Result := server_service_soap.TSOAPFormatter.Create() as IFormatterResponse; +end; + +function TTest_SoapFormatterExceptionBlock.CreateFormatterClient() : IFormatterClient; +begin + Result := soap_formatter.TSOAPFormatter.Create() as IFormatterClient; +end; + +function FindAttributeByValueInNode( + const AAttValue : string; + const ANode : TDOMNode; + out AResAtt : string +):boolean; +Var + i,c : Integer; +begin + AResAtt := ''; + if Assigned(ANode) and + Assigned(ANode.Attributes) and + ( ANode.Attributes.Length > 0 ) + then begin + c := Pred(ANode.Attributes.Length); + For i := 0 To c Do Begin + If AnsiSameText(AAttValue,ANode.Attributes.Item[i].NodeValue) Then Begin + AResAtt := ANode.Attributes.Item[i].NodeName; + Result := True; + Exit; + End; + End; + end; + Result := False; +end; + +procedure TTest_SoapFormatterExceptionBlock.ExceptBlock_server(); +const + VAL_CODE = 'Server.CustomCode.Test'; VAL_MSG = 'This is a sample exception message.'; +var + f : IFormatterResponse; + strm : TMemoryStream; + + envNd : TDOMElement; + bdyNd, fltNd, hdrNd, tmpNode : TDOMNode; + nsShortName,eltName, msgBuff : string; + doc : TXMLDocument; +begin + f := CreateFormatter(); + f.BeginExceptionList(VAL_CODE,VAL_MSG); + f.EndExceptionList(); + strm := TMemoryStream.Create(); + try + f.SaveToStream(strm);strm.SaveToFile('TTest_SoapFormatterExceptionBlock.ExceptBlock.xml'); + strm.Position := 0; + ReadXMLFile(doc,strm); + if FindAttributeByValueInNode(sSOAP_ENV,doc.DocumentElement,nsShortName) or + FindAttributeByValueInNode('"' + sSOAP_ENV + '"',doc.DocumentElement,nsShortName) + then begin + nsShortName := Copy(nsShortName,1 + Pos(':',nsShortName),MaxInt); + if not IsStrEmpty(nsShortName) then + nsShortName := nsShortName + ':'; + end else begin + nsShortName := ''; + end; + eltName := nsShortName + sENVELOPE; + envNd := doc.DocumentElement; + if not SameText(eltName,envNd.NodeName) then + check(False,Format('XML root node must be "Envelope", found : "%s"',[envNd.NodeName + ':::' + nsShortName])); + + bdyNd := envNd.FirstChild; + if not Assigned(bdyNd) then + check(False,'Node not found : "Body".'); + + eltName := nsShortName + 'Body'; + if not SameText(bdyNd.NodeName,eltName) then begin + check(False,'Node not found : "Body".'); + end; + + bdyNd := envNd.FirstChild; + If Not Assigned(bdyNd) Then + check(False,'Node not found : "Body"'); + If Not SameText(bdyNd.NodeName,eltName) Then + bdyNd := bdyNd.NextSibling; + If Not Assigned(bdyNd) Then + Check(False,'Node not found : "Body"'); + If Not Assigned(bdyNd.FirstChild) Then + Check(False,'Response Node not found'); + eltName := nsShortName + 'Fault'; + if SameText(eltName,bdyNd.FirstChild.NodeName) then begin + fltNd := bdyNd.FirstChild; + eltName := 'faultcode'; + tmpNode := FindNode(fltNd,eltName); + if not Assigned(tmpNode) then + Check(False,Format('"%s" Node not found.',[eltName])); + if tmpNode.HasChildNodes then + msgBuff := tmpNode.FirstChild.NodeValue + else + msgBuff := tmpNode.NodeValue; + CheckEquals(VAL_CODE,msgBuff,eltName); + + eltName := 'faultstring'; + tmpNode := FindNode(fltNd,eltName); + if not Assigned(tmpNode) then + Check(False,Format('"%s" Node not found.',[eltName])); + if tmpNode.HasChildNodes then + msgBuff := tmpNode.FirstChild.NodeValue + else + msgBuff := tmpNode.NodeValue; + CheckEquals(VAL_MSG,msgBuff,eltName); + end; + finally + FreeAndNil(strm); + end; +end; + +procedure TTest_SoapFormatterExceptionBlock.ExceptBlock_client(); +const + VAL_CODE = 'Server.CustomCode.Test'; VAL_MSG = 'This is a sample exception message.'; + VAL_STREAM = + ' '+ + ' ' + + ' '+ + ' '+ + ' ' + VAL_CODE + ' '+ + ' ' + VAL_MSG +' '+ + ' '+ + ' '+ + ' '; +var + f : IFormatterClient; + strm : TStringStream; + excpt_code, excpt_msg : string; +begin + excpt_code := ''; + excpt_msg := ''; + f := CreateFormatterClient(); + strm := TStringStream.Create(VAL_STREAM); + try + strm.Position := 0; + f.LoadFromStream(strm); + try + f.BeginCallRead(nil); + Check(False,'BeginCallRead() should raise an exception.'); + except + on e : ESOAPException 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; +end; + +{$IFDEF WST_RECORD_RTTI} +function __TTestSmallRecord_TYPEINFO_FUNC__() : PTypeInfo; +var + p : ^TTestSmallRecord; + r : TTestSmallRecord; +begin + p := @r; + Result := MakeRawTypeInfo( + 'TTestSmallRecord', + SizeOf(TTestSmallRecord), + [ PtrUInt(@(p^.fieldSmallint)) - PtrUInt(p), PtrUInt(@(p^.fieldWord)) - PtrUInt(p), PtrUInt(@(p^.fieldString)) - PtrUInt(p) ], + [ TypeInfo(SmallInt), TypeInfo(Word), TypeInfo(String) ] + ); +end; +{$ENDIF WST_RECORD_RTTI} + +{$IFDEF WST_RECORD_RTTI} +function __TTestRecord_TYPEINFO_FUNC__() : PTypeInfo; +var + p : ^TTestRecord; + r : TTestRecord; +begin + p := @r; + Result := MakeRawTypeInfo( + 'TTestRecord', + SizeOf(TTestRecord), + [ PtrUInt(@(p^.fieldByte)) - PtrUInt(p), PtrUInt(@(p^.fieldShortInt)) - PtrUInt(p), PtrUInt(@(p^.fieldSmallint)) - PtrUInt(p), PtrUInt(@(p^.fieldWord)) - PtrUInt(p), PtrUInt(@(p^.fieldInteger)) - PtrUInt(p), PtrUInt(@(p^.fieldLongWord)) - PtrUInt(p), PtrUInt(@(p^.fieldInt64)) - PtrUInt(p), PtrUInt(@(p^.fieldQWord)) - PtrUInt(p), PtrUInt(@(p^.fieldComp)) - PtrUInt(p), PtrUInt(@(p^.fieldSingle)) - PtrUInt(p), PtrUInt(@(p^.fieldDouble)) - PtrUInt(p), PtrUInt(@(p^.fieldExtended)) - PtrUInt(p), PtrUInt(@(p^.fieldCurrency)) - PtrUInt(p), PtrUInt(@(p^.fieldBoolean)) - PtrUInt(p), PtrUInt(@(p^.fieldString)) - PtrUInt(p), PtrUInt(@(p^.fieldRecord)) - PtrUInt(p) ], + [ TypeInfo(Byte), TypeInfo(ShortInt), TypeInfo(SmallInt), TypeInfo(Word), TypeInfo(Integer), TypeInfo(LongWord), TypeInfo(Int64), TypeInfo(QWord), TypeInfo(Comp), TypeInfo(Single), TypeInfo(Double), TypeInfo(Extended), TypeInfo(Currency), TypeInfo(Boolean), TypeInfo(String), TypeInfo(TTestSmallRecord) ] + ); +end; +{$ENDIF WST_RECORD_RTTI} + +procedure TTest_SoapFormatterExceptionBlock.SetUp(); +begin + inherited; +{$IFNDEF FPC} + CoInitialize(nil); +{$ENDIF} +end; + +procedure TTest_SoapFormatterExceptionBlock.TearDown(); +begin +{$IFNDEF FPC} + CoUninitialize(); +{$ENDIF} + inherited; +end; + +{ TTest_XmlRpcFormatterExceptionBlock } + +procedure TTest_XmlRpcFormatterExceptionBlock.SetUp(); +begin + inherited; +{$IFNDEF FPC} + CoInitialize(nil); +{$ENDIF} +end; + +procedure TTest_XmlRpcFormatterExceptionBlock.TearDown(); +begin +{$IFNDEF FPC} + CoUninitialize(); +{$ENDIF} + inherited; +end; + +function TTest_XmlRpcFormatterExceptionBlock.CreateFormatter() : IFormatterResponse; +begin + Result := server_service_xmlrpc.TXmlRpcFormatter.Create() as IFormatterResponse; +end; + +function TTest_XmlRpcFormatterExceptionBlock.CreateFormatterClient() : IFormatterClient; +begin + Result := xmlrpc_formatter.TXmlRpcFormatter.Create() as IFormatterClient; +end; + +procedure TTest_XmlRpcFormatterExceptionBlock.ExceptBlock_server(); + function loc_FindNode(AScope : TDOMNode; const ANodeName: string): TDOMNode; + var + memberNode, tmpNode : TDOMNode; + i : Integer; + chilNodes : TDOMNodeList; + nodeFound : Boolean; + begin + Result := nil; + if AScope.HasChildNodes() then begin + nodeFound := False; + memberNode := AScope.FirstChild; + while ( not nodeFound ) and ( memberNode <> nil ) do begin + if memberNode.HasChildNodes() then begin + chilNodes := memberNode.ChildNodes; + for i := 0 to Pred(GetNodeListCount(chilNodes)) do begin + tmpNode := chilNodes.Item[i]; + if AnsiSameText(sNAME,tmpNode.NodeName) and + ( tmpNode.FirstChild <> nil ) and + AnsiSameText(ANodeName,tmpNode.FirstChild.NodeValue) + then begin + nodeFound := True; + Break; + end; + end; + if nodeFound then begin + tmpNode := FindNode(memberNode,sVALUE); + if ( tmpNode <> nil ) and ( tmpNode.FirstChild <> nil ) then begin + Result := tmpNode.FirstChild; + Break; + end; + end; + end; + memberNode := memberNode.NextSibling; + end; + end; + end; + +const VAL_CODE = '1210'; VAL_MSG = 'This is a sample exception message.'; +var + f : IFormatterResponse; + strm : TMemoryStream; + callNode : TDOMElement; + faultNode, faultStruct, tmpNode : TDOMNode; + doc : TXMLDocument; + eltName : string; + excpt_Obj : EXmlRpcException; + excpt_code, excpt_msg : string; +begin + f := CreateFormatter(); + f.BeginExceptionList(VAL_CODE,VAL_MSG); + f.EndExceptionList(); + strm := TMemoryStream.Create(); + try + f.SaveToStream(strm);strm.SaveToFile('TTest_XmlRpcFormatterExceptionBlock.ExceptBlock.xml'); + strm.Position := 0; + ReadXMLFile(doc,strm); + callNode := doc.DocumentElement; + if not SameText(base_xmlrpc_formatter.sMETHOD_RESPONSE,callNode.NodeName) then + Check(False,Format('XML root node must be "%s".',[base_xmlrpc_formatter.sMETHOD_RESPONSE])); + + faultNode := FindNode(callNode,base_xmlrpc_formatter.sFAULT); + if ( faultNode = nil ) then begin + Check(False,Format('Invalid XmlRPC response message, "%s" or "%s" are not present.',[base_xmlrpc_formatter.sPARAMS,base_xmlrpc_formatter.sFAULT])); + end; + tmpNode := FindNode(faultNode,base_xmlrpc_formatter.sVALUE); + if ( tmpNode = nil ) then begin + Check(False,Format('Invalid XmlRPC fault response message, "%s" is not present.',[base_xmlrpc_formatter.sVALUE])); + end; + faultStruct := FindNode(tmpNode,XmlRpcDataTypeNames[xdtStruct]); + if ( faultStruct = nil ) then begin + Check(False,Format('Invalid XmlRPC fault response message, "%s" is not present.',[XmlRpcDataTypeNames[xdtStruct]])); + end; + tmpNode := loc_FindNode(faultStruct,base_xmlrpc_formatter.sFAULT_CODE); + if ( tmpNode = nil ) then begin + Check(False,Format('Invalid XmlRPC fault response message, "%s" is not present.',[base_xmlrpc_formatter.sFAULT_CODE])); + end; + excpt_code := tmpNode.FirstChild.NodeValue; + CheckEquals(VAL_CODE,excpt_code,base_xmlrpc_formatter.sFAULT_STRING); + tmpNode := loc_FindNode(faultStruct,base_xmlrpc_formatter.sFAULT_STRING); + if ( tmpNode = nil ) then begin + Check(False,Format('Invalid XmlRPC fault response message, "%s" is not present.',[base_xmlrpc_formatter.sFAULT_STRING])); + end; + excpt_msg := tmpNode.FirstChild.NodeValue; + CheckEquals(VAL_MSG,excpt_msg,base_xmlrpc_formatter.sFAULT_STRING); + finally + FreeAndNil(strm); + end; +end; + +procedure TTest_XmlRpcFormatterExceptionBlock.ExceptBlock_client(); +const + VAL_CODE = '1210'; VAL_MSG = 'This is a sample exception message.'; + VAL_STREAM = +' ' + +' ' + + ' ' + + ' ' + + ' ' + + ' ' + + ' faultCode ' + + ' ' + + ' ' + VAL_CODE + ' ' + + ' ' + + ' ' + + ' ' + + ' faultString ' + + ' ' + + ' ' + VAL_MSG + ' ' + + ' ' + + ' ' + + ' ' + + ' ' + + ' ' + +' '; +var + f : IFormatterClient; + strm : TStringStream; + excpt_code, excpt_msg : string; +begin + excpt_code := ''; + excpt_msg := ''; + f := CreateFormatterClient(); + strm := TStringStream.Create(VAL_STREAM); + try + strm.Position := 0; + f.LoadFromStream(strm); + try + f.BeginCallRead(nil); + Check(False,'BeginCallRead() should raise an exception.'); + except + on e : EXmlRpcException 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; +end; + initialization RegisterStdTypes(); GetTypeRegistry().Register(sXSD_NS,TypeInfo(TTestEnum),'TTestEnum').RegisterExternalPropertyName('teOne', '1'); @@ -3177,6 +3751,22 @@ initialization RegisterExternalPropertyName(sARRAY_STYLE,sEmbedded); end; + GetTypeRegistry().Register(sWST_BASE_NS,TypeInfo(TTestSmallRecord),'TTestSmallRecord').RegisterExternalPropertyName('__FIELDS__','fieldSmallint;fieldWord;fieldString'); +{$IFNDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestSmallRecord)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(TypeInfo(TTestSmallRecord)),GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestSmallRecord)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} +{$IFDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestSmallRecord)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(__TTestSmallRecord_TYPEINFO_FUNC__()),GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestSmallRecord)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} + + GetTypeRegistry().Register(sWST_BASE_NS,TypeInfo(TTestRecord),'TTestRecord').RegisterExternalPropertyName('__FIELDS__','fieldByte;fieldShortInt;fieldSmallint;fieldWord;fieldInteger;fieldLongWord;fieldInt64;fieldQWord;fieldComp;fieldSingle;fieldDouble;fieldExtended;fieldCurrency;fieldBoolean;fieldString;fieldRecord'); +{$IFNDEF WST_RECORD_RTTI} + GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestRecord)].RegisterObject(FIELDS_STRING,TRecordRttiDataObject.Create(MakeRecordTypeInfo(TypeInfo(TTestRecord)),GetTypeRegistry().ItemByTypeInfo[TypeInfo(TTestRecord)].GetExternalPropertyName('__FIELDS__'))); +{$ENDIF WST_RECORD_RTTI} +{$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} + {$IFDEF FPC} RegisterTest(TTestArray); RegisterTest(TTestSOAPFormatter); @@ -3190,6 +3780,8 @@ initialization RegisterTest(TTestXmlRpcFormatterAttributes); RegisterTest(TTestXmlRpcFormatter); + RegisterTest(TTest_SoapFormatterExceptionBlock); + RegisterTest(TTest_XmlRpcFormatterExceptionBlock); {$ELSE} RegisterTest(TTestArray.Suite); RegisterTest(TTestSOAPFormatter.Suite); @@ -3203,5 +3795,9 @@ initialization RegisterTest(TTestXmlRpcFormatterAttributes.Suite); RegisterTest(TTestXmlRpcFormatter.Suite); + RegisterTest(TTest_SoapFormatterExceptionBlock.Suite); + RegisterTest(TTest_XmlRpcFormatterExceptionBlock.Suite); {$ENDIF} + + end. diff --git a/wst/trunk/tests/test_suite/testmetadata_unit.pas b/wst/trunk/tests/test_suite/testmetadata_unit.pas index 6fab0a4f8..5b7bea9c8 100644 --- a/wst/trunk/tests/test_suite/testmetadata_unit.pas +++ b/wst/trunk/tests/test_suite/testmetadata_unit.pas @@ -27,9 +27,6 @@ uses pascal_parser_intf, metadata_wsdl; -{$INCLUDE wst.inc} -{$INCLUDE wst_delphi.inc} - type { TTestMetadata } diff --git a/wst/trunk/tests/test_suite/wst_test_suite.lpi b/wst/trunk/tests/test_suite/wst_test_suite.lpi index df7afd6a4..ce091b8e0 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 @@ - + @@ -27,27 +27,25 @@ - + - - - + + - - - - + + + - + @@ -55,25 +53,29 @@ - - + + + + - - + + + + - - - + + + @@ -81,13 +83,13 @@ - - + + - - + + @@ -95,9 +97,9 @@ - - - + + + @@ -105,17 +107,19 @@ - - + + + + - + - + @@ -126,34 +130,34 @@ - + + + - - + + - - - + + - - - + + @@ -161,20 +165,19 @@ - + - - - + + - - - + + + @@ -183,61 +186,63 @@ - + - + - + - + - - - + + + + + - + - + - + - + - + @@ -246,302 +251,280 @@ - + - + - - - - - - - - - - - - - - - - - - + + + + + + + - - - + + + - - - + + + - - - + + + - - - - - - - - - - + + + - - - + + + - - - + + + - - - - + + + + - - + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - + + + - - - - - + + + + + - + - - - + + + - - - + + + - + - - + + - - + + - - - - - + + + + + - + - - - - - + + + - - - + + + - - - - - + + + + + - - - + + + - - - + + + - - - + + + - - - - - - - + + + + + - - - + + + @@ -549,11 +532,9 @@ - - - - - + + + @@ -561,11 +542,9 @@ - - - - - + + + @@ -573,11 +552,9 @@ - - - - - + + + @@ -585,11 +562,9 @@ - - - - - + + + @@ -597,12 +572,76 @@ - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -622,6 +661,10 @@ + + + + diff --git a/wst/trunk/tests/test_suite/wst_test_suite.lpr b/wst/trunk/tests/test_suite/wst_test_suite.lpr index c561f7d8a..21cd81ce8 100644 --- a/wst/trunk/tests/test_suite/wst_test_suite.lpr +++ b/wst/trunk/tests/test_suite/wst_test_suite.lpr @@ -15,7 +15,8 @@ uses base_service_intf, base_soap_formatter, binary_formatter, binary_streamer, server_binary_formatter, metadata_repository, metadata_generator, parserdefs, server_service_intf, metadata_wsdl, - test_parserdef, base_xmlrpc_formatter, wst_fpc_xml, test_utilities; + test_parserdef, base_xmlrpc_formatter, wst_fpc_xml, test_utilities, + server_service_xmlrpc; Const ShortOpts = 'alh'; diff --git a/wst/trunk/type_lib_edtr/typ_lib_edtr.lpi b/wst/trunk/type_lib_edtr/typ_lib_edtr.lpi index 5416f9282..6fe5f7b82 100644 --- a/wst/trunk/type_lib_edtr/typ_lib_edtr.lpi +++ b/wst/trunk/type_lib_edtr/typ_lib_edtr.lpi @@ -7,7 +7,7 @@ - + @@ -32,13 +32,13 @@ - + - + @@ -49,8 +49,8 @@ - - + + @@ -60,15 +60,15 @@ - + - - - - + + + + @@ -78,13 +78,10 @@ - - - + + + - - - @@ -96,9 +93,7 @@ - - @@ -109,9 +104,7 @@ - - @@ -119,17 +112,15 @@ - - - - - + + + @@ -138,8 +129,8 @@ - - + + @@ -152,9 +143,7 @@ - - @@ -164,100 +153,98 @@ - - - + - - + + - + - + - + - + - + - + - + - + - + - + - + - + @@ -267,15 +254,13 @@ - - - + - + @@ -286,82 +271,87 @@ - + - + - - - - + + + + - - - + + + + + - + - - - - + + + + - + - + - + - + - - - - + + + + + + + @@ -369,49 +359,49 @@ - + - + - + - + - + - + - + @@ -420,28 +410,28 @@ - + - + - + - + @@ -451,14 +441,14 @@ - + - + @@ -466,14 +456,14 @@ - + - + @@ -483,20 +473,20 @@ - + - + - + @@ -507,14 +497,14 @@ - + - + @@ -524,38 +514,38 @@ - + - + - + - - - + + + - + - + @@ -565,42 +555,40 @@ - + - + - + - - - + - + @@ -610,9 +598,7 @@ - - - + @@ -622,95 +608,195 @@ - - - + - + - + - + - + - + - + - + - + + + + + + + + + + + + + + + - + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wst/trunk/type_lib_edtr/uwsttypelibraryedit.pas b/wst/trunk/type_lib_edtr/uwsttypelibraryedit.pas index 77a7fbfee..06e189dcb 100644 --- a/wst/trunk/type_lib_edtr/uwsttypelibraryedit.pas +++ b/wst/trunk/type_lib_edtr/uwsttypelibraryedit.pas @@ -230,9 +230,9 @@ begin DoNotify(mtInfo,Format('File parsed %s .',[AFileName])); except on e : Exception do begin - FreeAndNil(Result); DoNotify(mtError,e.Message); - raise; + FreeAndNil(Result); + //raise; end; end; end; diff --git a/wst/trunk/type_lib_edtr/wsdl_generator.pas b/wst/trunk/type_lib_edtr/wsdl_generator.pas index 1039ddc24..685d68ef9 100644 --- a/wst/trunk/type_lib_edtr/wsdl_generator.pas +++ b/wst/trunk/type_lib_edtr/wsdl_generator.pas @@ -10,11 +10,9 @@ but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. } - +{$INCLUDE wst_global.inc} unit wsdl_generator; -{$INCLUDE wst.inc} - interface uses diff --git a/wst/trunk/ws_helper/generator.pas b/wst/trunk/ws_helper/generator.pas index ec6495ddf..407f6c54e 100644 --- a/wst/trunk/ws_helper/generator.pas +++ b/wst/trunk/ws_helper/generator.pas @@ -17,11 +17,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. } - +{$INCLUDE wst_global.inc} unit generator; -{$mode objfpc}{$H+} - interface uses @@ -149,6 +147,7 @@ type FImpStream : ISourceStream; FImpTempStream : ISourceStream; FImpLastStream : ISourceStream; + FRttiFunc : ISourceStream; private function GenerateIntfName(AIntf : TPasElement):string; @@ -161,6 +160,7 @@ type procedure GenerateClass(ASymbol : TPasClassType); procedure GenerateEnum(ASymbol : TPasEnumType); procedure GenerateArray(ASymbol : TPasArrayType); + procedure GenerateRecord(ASymbol : TPasRecordType); procedure GenerateCustomMetadatas(); function GetDestUnitName():string; @@ -185,6 +185,7 @@ Const sPROXY_BASE_CLASS = 'TBaseProxy'; RETURN_VAL_NAME = 'returnVal'; sNAME_SPACE = 'sNAME_SPACE'; sUNIT_NAME = 'sUNIT_NAME'; + sRECORD_RTTI_DEFINE = 'WST_RECORD_RTTI'; sPRM_NAME = 'strPrmName'; sLOC_SERIALIZER = 'locSerializer'; @@ -1398,7 +1399,12 @@ begin WriteLn('}'); WriteLn('unit %s;',[GetDestUnitName()]); - WriteLn('{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}'); + WriteLn('{$IFDEF FPC}'); + WriteLn(' {$mode objfpc} {$H+}'); + WriteLn('{$ENDIF}'); + WriteLn('{$IFNDEF FPC}'); + WriteLn(' {$DEFINE WST_RECORD_RTTI}'); + WriteLn('{$ENDIF}'); WriteLn('interface'); WriteLn(''); WriteLn('uses SysUtils, Classes, TypInfo, base_service_intf, service_intf;'); @@ -1420,7 +1426,7 @@ begin SetCurrentStream(FImpStream); WriteLn(''); WriteLn('Implementation'); - WriteLn('uses metadata_repository;'); + WriteLn('uses metadata_repository, record_rtti, wst_types;'); FImpTempStream.WriteLn('initialization'); end; @@ -2033,6 +2039,122 @@ begin end; end; +procedure TInftGenerator.GenerateRecord(ASymbol : TPasRecordType); +var + strFieldList : string; + + procedure WriteDec(); + var + itm : TPasVariable; + i : PtrInt; + begin + SetCurrentStream(FDecStream); + NewLine(); + IncIndent(); + Indent(); WriteLn('%s = record',[ASymbol.Name]); + IncIndent(); + strFieldList := ''; + for i := 0 to Pred(ASymbol.Members.Count) do begin + itm := TPasVariable(ASymbol.Members[i]); + Indent(); + WriteLn('%s : %s;',[itm.Name,itm.VarType.Name]); + if ( i > 0 ) then + strFieldList := Format('%s;%s',[strFieldList,itm.Name]) + else + strFieldList := itm.Name; + end; + DecIndent(); + Indent(); WriteLn('end;'); + DecIndent(); + end; + + procedure WriteRTTI(); + var + itm : TPasVariable; + k, c : PtrInt; + offsetLine, typeLine : string; + begin + SetCurrentStream(FRttiFunc); + NewLine(); + WriteLn('{$IFDEF %s}',[sRECORD_RTTI_DEFINE]); + WriteLn('function __%s_TYPEINFO_FUNC__() : PTypeInfo;',[ASymbol.Name]); + WriteLn('var'); + IncIndent(); + Indent(); WriteLn('p : ^%s;',[ASymbol.Name]); + Indent(); WriteLn('r : %s;',[ASymbol.Name]); + DecIndent(); + WriteLn('begin'); + IncIndent(); + Indent(); WriteLn('p := @r;'); + Indent(); WriteLn('Result := MakeRawTypeInfo('); + IncIndent(); + Indent(); WriteLn('%s,',[QuotedStr(ASymbol.Name)]); + Indent(); WriteLn('SizeOf(%s),',[ASymbol.Name]); + offsetLine := '[ '; + typeLine := '[ '; + c := ASymbol.Members.Count; + if ( c > 0 ) then begin + k := 1; + itm := TPasVariable(ASymbol.Members[(k-1)]); + offsetLine := offsetLine + Format('PtrUInt(@(p^.%s)) - PtrUInt(p)',[itm.Name]); + typeLine := typeLine + Format('TypeInfo(%s)',[itm.VarType.Name]); + Inc(k); + for k := k to c do begin + itm := TPasVariable(ASymbol.Members[(k-1)]); + offsetLine := offsetLine + Format(', PtrUInt(@(p^.%s)) - PtrUInt(p)',[itm.Name]); + typeLine := typeLine + Format(', TypeInfo(%s)',[itm.VarType.Name]); + end; + end; + offsetLine := offsetLine + ' ]'; + typeLine := typeLine + ' ]'; + Indent(); WriteLn('%s,',[offsetLine]); + Indent(); WriteLn('%s',[typeLine]); + DecIndent(); + Indent(); WriteLn(');'); + DecIndent(); + WriteLn('end;'); + WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]); + end; + +var + s : string; +begin + try + WriteDec(); + WriteRTTI(); + + SetCurrentStream(FImpLastStream); + NewLine(); + + Indent(); + WriteLn( + 'GetTypeRegistry().Register(%s,TypeInfo(%s),%s).RegisterExternalPropertyName(%s,%s);', + [ sNAME_SPACE,ASymbol.Name,QuotedStr(SymbolTable.GetExternalName(ASymbol)), + QuotedStr(Format('__FIELDS__',[ASymbol.Name])),QuotedStr(strFieldList) + ] + ); + s := 'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)]' + + '.RegisterObject(' + + 'FIELDS_STRING,' + + 'TRecordRttiDataObject.Create(' + + 'MakeRecordTypeInfo(%s),' + + 'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].GetExternalPropertyName(''__FIELDS__'')' + + ')' + + ');'; + WriteLn('{$IFNDEF %s}',[sRECORD_RTTI_DEFINE]); + Indent(); WriteLn(s,[ASymbol.Name,Format('TypeInfo(%s)',[ASymbol.Name]),ASymbol.Name]); + WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]); + + WriteLn('{$IFDEF %s}',[sRECORD_RTTI_DEFINE]); + Indent(); WriteLn(s,[ASymbol.Name,Format('__%s_TYPEINFO_FUNC__()',[ASymbol.Name]),ASymbol.Name]); + WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]); + SetCurrentStream(FDecStream); + except + on e : Exception do + GetLogger.Log(mtError,'TInftGenerator.GenerateRecord()=', [ASymbol.Name, ' ;; ', e.Message]); + end; +end; + procedure TInftGenerator.GenerateCustomMetadatas(); procedure WriteOperationDatas(AInftDef : TPasClassType; AOp : TPasProcedure); @@ -2140,13 +2262,14 @@ begin FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp'); FImpTempStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp'); FImpLastStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp_last'); + FRttiFunc := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_rtti_func'); FImpTempStream.IncIndent(); FImpLastStream.IncIndent(); end; procedure TInftGenerator.Execute(); var - i,c, j, k : Integer; + i,c, j, k : PtrInt; clssTyp : TPasClassType; gnrClssLst : TObjectList; objLst : TObjectList; @@ -2194,6 +2317,13 @@ begin end; end; + for i := 0 to c do begin + elt := TPasElement(typeList[i]); + if elt.InheritsFrom(TPasRecordType) then begin + GenerateRecord(TPasRecordType(elt)); + end; + end; + for i := 0 to c do begin elt := TPasElement(typeList[i]); if elt.InheritsFrom(TPasAliasType) then begin @@ -2258,8 +2388,9 @@ begin DecIndent(); GenerateCustomMetadatas(); + FImpLastStream.NewLine(); GenerateUnitImplementationFooter(); - FSrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FImpStream,FImpTempStream,FImpLastStream]); + FSrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FImpStream,FRttiFunc,FImpTempStream,FImpLastStream]); FDecStream := nil; FImpStream := nil; FImpTempStream := nil; diff --git a/wst/trunk/ws_helper/pascal_parser_intf.pas b/wst/trunk/ws_helper/pascal_parser_intf.pas index 232b8a9a7..034366cf3 100644 --- a/wst/trunk/ws_helper/pascal_parser_intf.pas +++ b/wst/trunk/ws_helper/pascal_parser_intf.pas @@ -451,7 +451,7 @@ begin Result.SourceLinenumber := ASourceLinenumber; if Result.InheritsFrom(TPasModule) then begin FCurrentModule := Result as TPasModule; - Package.Modules.Add(Result); + //Package.Modules.Add(Result); end; end; diff --git a/wst/trunk/ws_helper/source_utils.pas b/wst/trunk/ws_helper/source_utils.pas index 6edb94f50..e5ad5783a 100644 --- a/wst/trunk/ws_helper/source_utils.pas +++ b/wst/trunk/ws_helper/source_utils.pas @@ -31,6 +31,10 @@ Type EsourceException = class(Exception) end; + ISourceStream = interface; + ISourceManager = interface; + ISavableSourceStream = interface; + ISourceStream = interface ['{91EA7DA6-340C-477A-A6FD-06F2BAEA9A97}'] function GetFileName():string; @@ -45,6 +49,7 @@ Type procedure NewLine(); procedure BeginAutoIndent(); procedure EndAutoIndent(); + procedure Append(ASource : ISavableSourceStream); end; ISourceManager = Interface @@ -98,6 +103,7 @@ type procedure BeginAutoIndent(); procedure EndAutoIndent(); function IsInAutoInden():Boolean; + procedure Append(ASource : ISavableSourceStream); Public constructor Create(const AFileName:string); destructor Destroy();override; @@ -303,6 +309,12 @@ begin Result := ( FAutoIndentCount > 0 ); end; +procedure TSourceStream.Append(ASource : ISavableSourceStream); +begin + if ( ASource <> nil ) then + FStream.CopyFrom(ASource.GetStream(),0); +end; + constructor TSourceStream.Create(const AFileName: string); begin FFileName := AFileName; diff --git a/wst/trunk/wst.inc b/wst/trunk/wst.inc index f8994b50e..6eb717301 100644 --- a/wst/trunk/wst.inc +++ b/wst/trunk/wst.inc @@ -3,8 +3,4 @@ const FPC_VERSION = 0; {$ENDIF} -{$IFDEF FPC} - {$IF( (FPC_VERSION = 2) and (FPC_RELEASE > 0) ) } - {$define FPC_211} - {$IFEND} -{$ENDIF} + diff --git a/wst/trunk/wst_delphi.inc b/wst/trunk/wst_delphi.inc index bcded8209..4a753d899 100644 --- a/wst/trunk/wst_delphi.inc +++ b/wst/trunk/wst_delphi.inc @@ -1,4 +1,4 @@ -{$IFNDEF HAS_QWORD} +{$IFNDEF FPC} type QWord = type Int64; DWORD = LongWord; diff --git a/wst/trunk/wst_delphi_xml.pas b/wst/trunk/wst_delphi_xml.pas index 2e580eb6d..60715e5a5 100644 --- a/wst/trunk/wst_delphi_xml.pas +++ b/wst/trunk/wst_delphi_xml.pas @@ -24,7 +24,7 @@ type function CreateDoc() : TXMLDocument ; procedure WriteXMLFile(ADoc : TXMLDocument; AStream : TStream); - procedure ReadXMLFile(ADoc : TXMLDocument; AStream : TStream); + procedure ReadXMLFile(out ADoc : TXMLDocument; AStream : TStream); function NodeToBuffer(ANode : TDOMNode):string ; function FilterList(const ALIst : IDOMNodeList; const ANodeName : widestring):IDOMNodeList ; @@ -55,8 +55,9 @@ begin (ADoc as IDOMPersist).saveToStream(AStream); end; -procedure ReadXMLFile(ADoc : TXMLDocument; AStream : TStream); +procedure ReadXMLFile(out ADoc : TXMLDocument; AStream : TStream); begin + ADoc := CreateDoc(); (ADoc as IDOMPersist).loadFromStream(AStream); end; diff --git a/wst/trunk/wst_global.inc b/wst/trunk/wst_global.inc index c34e3fc91..6b6fe9361 100644 --- a/wst/trunk/wst_global.inc +++ b/wst/trunk/wst_global.inc @@ -5,4 +5,16 @@ {$ELSE} {$UNDEF HAS_QWORD} {$UNDEF USE_INLINE} + {$DEFINE WST_RECORD_RTTI} +{$ENDIF} +{$IFDEF CPU86} + {$DEFINE HAS_COMP} +{$ENDIF} + +{$IFDEF FPC} + {$IF Defined(FPC_VERSION) and (FPC_VERSION = 2) } + {$IF Defined(FPC_RELEASE) and (FPC_RELEASE > 0) } + {$define FPC_211} + {$IFEND} + {$IFEND} {$ENDIF} diff --git a/wst/trunk/wst_types.pas b/wst/trunk/wst_types.pas new file mode 100644 index 000000000..09b2a7438 --- /dev/null +++ b/wst/trunk/wst_types.pas @@ -0,0 +1,42 @@ +{ + This file is part of the Web Service Toolkit + Copyright (c) 2006 by Inoussa OUEDRAOGO + + This file is provide under modified LGPL licence + ( the files COPYING.modifiedLGPL and COPYING.LGPL). + + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} +{$INCLUDE wst_global.inc} +unit wst_types; + +interface + +{$INCLUDE wst.inc} +{$INCLUDE wst_delphi.inc} + +type + + { TDataObject } + + TDataObject = class + private + FData : Pointer; + public + constructor Create(const AData : Pointer); + property Data : Pointer read FData write FData; + end; + +implementation + +{ TDataObject } + +constructor TDataObject.Create(const AData : Pointer); +begin + FData := AData; +end; + +end.