pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Serialization : By default, attributes are no longer qualified.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1114 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
inoussa
2010-01-05 19:59:56 +00:00
parent a9dc8441be
commit 34030812f8
8 changed files with 616 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files

217
wst/trunk/base_service_intf.pas
View File

@ -589,6 +589,7 @@ type
const ATypeInfo : PTypeInfo
);override;
end;
TBaseComplexSimpleContentRemotableClass = class of TBaseComplexSimpleContentRemotable;
{ TComplexInt8UContentRemotable }
@ -1533,7 +1534,7 @@ type
property TimeOut : PtrUInt read FTimeOut write FTimeOut;
end;
TTypeRegistryItemOption = ( trioNonVisibleToMetadataService );
TTypeRegistryItemOption = ( trioNonVisibleToMetadataService, trioNonQualifiedName );
TTypeRegistryItemOptions = set of TTypeRegistryItemOption;
TTypeRegistry = class;
TTypeRegistryItem = class;
@ -1555,10 +1556,28 @@ type
{$ENDIF TRemotableTypeInitializer_Initialize}
end;
TPropertyNameType = ( pntInternalName, pntExternalName );
{ TPropertyItem }
TPropertyItem = class
private
FExternalName: string;
FExtObject: TObject;
FInternalName: string;
FOptions: TTypeRegistryItemOptions;
public
property InternalName : string read FInternalName {write FInternalName};
property ExternalName : string read FExternalName {write FExternalName};
property ExtObject : TObject read FExtObject {write FExtObject};
property Options : TTypeRegistryItemOptions read FOptions {write FOptions};
end;
{ TTypeRegistryItem }
TTypeRegistryItem = class
private
//FDefaultPropertyOptions: TTypeRegistryItemOptions;
FOwner : TTypeRegistry;
FDataType: PTypeInfo;
FNameSpace: string;
@ -1566,12 +1585,14 @@ type
FOptions: TTypeRegistryItemOptions;
FPascalSynonyms : TStrings;
FExternalSynonyms : TStrings;
FExternalNames : TStrings;
FInternalNames : TStrings;
private
procedure CreateInternalObjects();{$IFDEF USE_INLINE}inline;{$ENDIF}
FProperties : TObjectList;
protected
procedure Init(); virtual;
protected
function IndexOfProp(
const AName : string;
const ANameType : TPropertyNameType
) : Integer;
public
constructor Create(
AOwner : TTypeRegistry;
@ -1585,9 +1606,17 @@ type
function IsSynonym(const APascalTypeName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function IsExternalSynonym(const AExternalName : string):Boolean;{$IFDEF USE_INLINE}inline;{$ENDIF}
function FindProperty(
const AName : string;
const ANameType : TPropertyNameType
) : TPropertyItem;
procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); virtual;
function GetExternalPropertyName(const APropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF}
function GetInternalPropertyName(const AExtPropName : string) : string;{$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPropertyOptions(
const APropName : string;
const AOptions : TTypeRegistryItemOptions
); virtual;
procedure RegisterObject(const APropName : string; const AObject : TObject);
function GetObject(const APropName : string) : TObject;
@ -1597,6 +1626,8 @@ type
property NameSpace : string read FNameSpace;
property DeclaredName : string read FDeclaredName;
property Options : TTypeRegistryItemOptions read FOptions write FOptions;
//property DefaultPropertyOptions : TTypeRegistryItemOptions
//read FDefaultPropertyOptions write FDefaultPropertyOptions;
end;
TTypeRegistrySearchOption = ( trsoIncludeExternalSynonyms );
@ -1782,6 +1813,7 @@ begin
THeaderBlock.RegisterAttributeProperty('mustUnderstand');
ri := r.Register(sSOAP_ENV,TypeInfo(THeaderBlock),'THeaderBlock');
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
ri.SetPropertyOptions('mustUnderstand',[]);
ri := r.Register(sSOAP_ENV,TypeInfo(TSimpleContentHeaderBlock));
ri.Options := ri.Options + [trioNonVisibleToMetadataService];
ri := r.Register(sSOAP_ENV,TypeInfo(THeaderBlockProxy));
@ -3071,19 +3103,54 @@ end;
{ TTypeRegistryItem }
procedure TTypeRegistryItem.CreateInternalObjects();
begin
if not Assigned(FExternalNames) then begin
FExternalNames := TStringList.Create();
FInternalNames := TStringList.Create();
end;
end;
procedure TTypeRegistryItem.Init();
begin
end;
function TTypeRegistryItem.IndexOfProp(
const AName: string;
const ANameType : TPropertyNameType
) : Integer;
var
i : Integer;
locName : string;
begin
Result := -1;
if ( FProperties <> nil ) and ( FProperties.Count > 0 ) then begin
locName := LowerCase(AName);
if ( ANameType = pntInternalName ) then begin
for i := 0 to Pred(FProperties.Count) do begin
if ( locName = LowerCase(TPropertyItem(FProperties[i]).InternalName) ) then begin
Result := i;
Break;
end;
end;
end else begin
for i := 0 to Pred(FProperties.Count) do begin
if ( locName = LowerCase(TPropertyItem(FProperties[i]).ExternalName) ) then begin
Result := i;
Break;
end;
end;
end;
end;
end;
function TTypeRegistryItem.FindProperty(
const AName: string;
const ANameType : TPropertyNameType
) : TPropertyItem;
var
i : Integer;
begin
i := IndexOfProp(AName,ANameType);
if ( i = -1 ) then
Result := nil
else
Result := TPropertyItem(FProperties[i]);
end;
constructor TTypeRegistryItem.Create(
AOwner : TTypeRegistry;
ANameSpace : String;
@ -3100,25 +3167,8 @@ begin
end;
destructor TTypeRegistryItem.Destroy();
procedure FreeObjects();
var
j, k : PtrInt;
obj : TObject;
begin
j := FExternalNames.Count;
for k := 0 to Pred(j) do begin
obj := FExternalNames.Objects[k];
if ( obj <> nil ) then
obj.Free();
end;
end;
begin
if ( FExternalNames <> nil ) and ( FExternalNames.Count > 0 ) then
FreeObjects();
FInternalNames.Free();
FExternalNames.Free();
FreeAndNil(FProperties);
FPascalSynonyms.Free();
FExternalSynonyms.Free();
inherited Destroy();
@ -3165,56 +3215,82 @@ begin
end;
procedure TTypeRegistryItem.RegisterExternalPropertyName(const APropName,AExtPropName: string);
var
i : Integer;
po : TPropertyItem;
begin
if not Assigned(FExternalNames) then begin
CreateInternalObjects();
i := IndexOfProp(APropName,pntInternalName);
if ( i = -1 ) then begin
if ( FProperties = nil ) then
FProperties := TObjectList.Create(True);
po := TPropertyItem.Create();
FProperties.Add(po);
po.FInternalName := APropName;
//po.FOptions := Self.DefaultPropertyOptions;
end else begin
po := TPropertyItem(FProperties[i]);
end;
FExternalNames.Values[APropName] := AExtPropName;
FInternalNames.Values[AExtPropName] := APropName;
po.FExternalName := AExtPropName;
end;
procedure TTypeRegistryItem.RegisterObject(const APropName : string; const AObject : TObject);
var
i : PtrInt;
begin
if not Assigned(FExternalNames) then begin
CreateInternalObjects();
i := IndexOfProp(APropName,pntInternalName);
if ( i = -1 ) then begin
RegisterExternalPropertyName(APropName,APropName);
i := IndexOfProp(APropName,pntInternalName);
end;
i := FExternalNames.IndexOfName(APropName);
if ( i < 0 ) then begin
FExternalNames.Values[APropName] := APropName;
i := FExternalNames.IndexOfName(APropName);
end;
FExternalNames.Objects[i] := AObject;
TPropertyItem(FProperties[i]).FExtObject := AObject;
end;
function TTypeRegistryItem.GetObject(const APropName : string) : TObject;
var
i : PtrInt;
p : TPropertyItem;
begin
Result := nil;
if Assigned(FExternalNames) then begin
i := FExternalNames.IndexOfName(APropName);
if ( i >= 0 ) then
Result := FExternalNames.Objects[i];
end;
p := FindProperty(APropName,pntInternalName);
if ( p = nil ) then
Result := nil
else
Result := p.ExtObject;
end;
function TTypeRegistryItem.GetExternalPropertyName(const APropName: string): string;
var
p : TPropertyItem;
begin
if Assigned(FExternalNames) and ( FExternalNames.IndexOfName(APropName) <> -1 ) then begin
Result := FExternalNames.Values[APropName];
end else begin
Result := APropName;
end;
p := FindProperty(APropName,pntInternalName);
if ( p = nil ) then
Result := APropName
else
Result := p.ExternalName;
end;
function TTypeRegistryItem.GetInternalPropertyName(const AExtPropName: string): string;
var
p : TPropertyItem;
begin
if Assigned(FInternalNames) and ( FInternalNames.IndexOfName(AExtPropName) <> -1 ) then
Result := FInternalNames.Values[AExtPropName]
p := FindProperty(AExtPropName,pntExternalName);
if ( p = nil ) then
Result := AExtPropName
else
Result := AExtPropName;
Result := p.InternalName;
end;
procedure TTypeRegistryItem.SetPropertyOptions(
const APropName: string;
const AOptions: TTypeRegistryItemOptions
);
var
po : TPropertyItem;
begin
po := FindProperty(APropName,pntInternalName);
if ( po = nil ) then begin
RegisterExternalPropertyName(APropName,APropName);
po := FindProperty(APropName,pntInternalName);
end;
po.FOptions := AOptions;
end;
{ TTypeRegistry }
@ -5160,6 +5236,17 @@ class procedure TBaseComplexSimpleContentRemotable.Save(
const AName: string;
const ATypeInfo: PTypeInfo
);
{$IFDEF USE_SERIALIZE}
var
locSerializer : TSimpleContentObjectSerializer;
begin
locSerializer := TSimpleContentObjectRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
if ( locSerializer <> nil ) then
locSerializer.Save(AObject,AStore,AName,ATypeInfo)
else
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
end;
{$ELSE USE_SERIALIZE}
Var
propList : PPropList;
i, propCount, propListLen : Integer;
@ -5313,6 +5400,7 @@ begin
AStore.SetSerializationStyle(oldSS);
end;
end;
{$ENDIF USE_SERIALIZE}
class procedure TBaseComplexSimpleContentRemotable.Load(
var AObject: TObject;
@ -5320,6 +5408,17 @@ class procedure TBaseComplexSimpleContentRemotable.Load(
var AName: string;
const ATypeInfo: PTypeInfo
);
{$IFDEF USE_SERIALIZE}
var
locSerializer : TSimpleContentObjectSerializer;
begin
locSerializer := TSimpleContentObjectRegistryItem(GetTypeRegistry().ItemByTypeInfo[ATypeInfo]).GetSerializer();
if ( locSerializer <> nil ) then
locSerializer.Read(AObject,AStore,AName,ATypeInfo)
else
raise ETypeRegistryException.CreateFmt(SERR_NoSerializerFoThisType,[ATypeInfo^.Name])
end;
{$ELSE USE_SERIALIZE}
Var
propList : PPropList;
i, propCount, propListLen : Integer;
@ -5484,6 +5583,7 @@ begin
end;
end;
end;
{$ENDIF USE_SERIALIZE}
{ TComplexInt32SContentRemotable }
@ -6464,6 +6564,7 @@ begin
if ( TypeRegistryInstance = nil ) then begin
TypeRegistryInstance := TTypeRegistry.Create();
TypeRegistryInstance.RegisterInitializer(TBaseComplexRemotableInitializer);
TypeRegistryInstance.RegisterInitializer(TSimpleContentObjectRemotableInitializer);
end;
if ( SerializeOptionsRegistryInstance = nil ) then
SerializeOptionsRegistryInstance := TSerializeOptionsRegistry.Create();

14
wst/trunk/base_soap_formatter.pas
View File

@ -841,10 +841,8 @@ Var
begin
strNodeName := AName;
if ( Style = Document ) then begin
if ( ANameSpace = '' ) then
namespaceLongName := StackTop().NameSpace
else
namespaceLongName := ANameSpace;
if ( namespaceLongName <> '' ) then begin
s := FindAttributeByValueInScope(namespaceLongName);
if IsStrEmpty(s) then begin
namespaceShortName := 'ns' + IntToStr(NextNameSpaceCounter());
@ -856,6 +854,7 @@ begin
strNodeName := s + ':' + strNodeName;
end;
end;
end;
if ( FSerializationStyle = ssNodeSerialization ) then begin
Result := FDoc.CreateElement(strNodeName);
@ -1024,9 +1023,11 @@ var
begin
strNodeName := AName;
if ( Style = Document ) then begin
if ( ANameSpace = '' ) then
if ( ANameSpace <> '' ) then begin
{if ( ANameSpace = '' ) then
s := StackTop().NameSpace
else
s := ANameSpace;}
s := ANameSpace;
namespaceShortName := FindAttributeByValueInScope(s);
if not IsStrEmpty(namespaceShortName) then begin
@ -1035,6 +1036,7 @@ begin
strNodeName := s + ':' + strNodeName;
end;
end;
end;
if ( FSerializationStyle = ssNodeSerialization ) then begin
locElt := StackTop().FindNode(strNodeName) As TDOMElement;
@ -1884,7 +1886,7 @@ procedure TSOAPBaseFormatter.Put(
const AData
);
begin
Put('',AName,ATypeInfo,AData);
Put(StackTop().NameSpace,AName,ATypeInfo,AData);
end;
procedure TSOAPBaseFormatter.PutScopeInnerValue(
@ -2167,7 +2169,7 @@ function TSOAPBaseFormatter.Get(
var AData
) : Boolean;
begin
Result := Get(ATypeInfo,'',AName,AData);
Result := Get(ATypeInfo,StackTop().NameSpace,AName,AData);
end;
procedure TSOAPBaseFormatter.GetScopeInnerValue(

414
wst/trunk/object_serializer.pas
View File

@ -100,6 +100,38 @@ type
property Options : TObjectSerializerOptions read FOptions write FOptions;
end;
TSimpleContentObjectSerializer = class
private
FSerializationInfos : TObjectList;
FTarget : TBaseComplexSimpleContentRemotableClass;
FRawPropList : PPropList;
FOptions : TObjectSerializerOptions;
private
procedure Prepare(ATypeRegistry : TTypeRegistry);
function FindInfo(const APropName : string) : TPropSerializationInfo;
procedure UpdateExternalName(const APropName, AExtPropName : string);
public
constructor Create(
ATargetClass : TBaseComplexSimpleContentRemotableClass;
ATypeRegistry : TTypeRegistry
);
destructor Destroy();override;
procedure Read(
var AObject : TObject;
AStore : IFormatterBase;
var AName : string;
const ATypeInfo : PTypeInfo
);
procedure Save(
AObject : TBaseRemotable;
AStore : IFormatterBase;
const AName : string;
const ATypeInfo : PTypeInfo
);
property Target : TBaseComplexSimpleContentRemotableClass read FTarget;
property Options : TObjectSerializerOptions read FOptions write FOptions;
end;
TGetSerializerFunction = function() : TObjectSerializer of object;
{ TBaseComplexTypeRegistryItem }
@ -115,6 +147,23 @@ type
function GetSerializer() : TObjectSerializer;{$IFDEF USE_INLINE}inline;{$ENDIF}
end;
{ TSimpleContentObjectRegistryItem }
TSimpleContentObjectRegistryItem = class(TTypeRegistryItem)
private
FSerializer : TSimpleContentObjectSerializer;
protected
procedure Init(); override;
public
destructor Destroy();override;
procedure RegisterExternalPropertyName(const APropName, AExtPropName : string); override;
procedure SetPropertyOptions(
const APropName : string;
const AOptions : TTypeRegistryItemOptions
); virtual;
function GetSerializer() : TSimpleContentObjectSerializer;{$IFDEF USE_INLINE}inline;{$ENDIF}
end;
{ TBaseComplexRemotableInitializer }
TBaseComplexRemotableInitializer = class(TRemotableTypeInitializer)
@ -129,6 +178,21 @@ type
{$ENDIF TRemotableTypeInitializer_Initialize}
end;
{ TBaseComplexRemotableInitializer }
TSimpleContentObjectRemotableInitializer = class(TRemotableTypeInitializer)
public
class function CanHandle(ATypeInfo : PTypeInfo) : Boolean;override;
class function GetItemClass(const ATypeInfo : PTypeInfo) : TTypeRegistryItemClass;override;
{$IFDEF TRemotableTypeInitializer_Initialize}
class function Initialize(
ATypeInfo : PTypeInfo;
ARegistryItem : TTypeRegistryItem
) : Boolean;override;
{$ENDIF TRemotableTypeInitializer_Initialize}
end;
implementation
uses
wst_consts;
@ -1208,6 +1272,7 @@ var
serArray : array of TPropSerializationInfo;
serInfo : TPropSerializationInfo;
regItem, thisRegItem : TTypeRegistryItem;
regPropItem : TPropertyItem;
st : TPropStoreType;
clPL : PPropList;
begin
@ -1229,18 +1294,40 @@ begin
ppi := FRawPropList^[i];
st := IsStoredPropClass(cl,ppi);
if ( st in [pstAlways,pstOptional] ) then begin
regPropItem := regItem.FindProperty(ppi^.Name,pntInternalName);
serInfo := TPropSerializationInfo.Create();
serArray[ppi^.NameIndex] := serInfo;
serInfo.FExternalName := regItem.GetExternalPropertyName(ppi^.Name);
serInfo.FName := ppi^.Name;
serInfo.FPersisteType := st;
serInfo.FPropInfo := ppi;
serInfo.FNameSpace := regItem.NameSpace;
if Target.IsAttributeProperty(ppi^.Name) then begin
serInfo.FStyle := ssAttibuteSerialization;
serInfo.FQualifiedName := True;
serInfo.FNameSpace := '';
end else begin
serInfo.FStyle := ssNodeSerialization;
end;
if ( regPropItem <> nil ) then begin
serInfo.FExternalName := regPropItem.ExternalName;
if ( trioNonQualifiedName in regPropItem.Options ) then begin
serInfo.FNameSpace := '';
serInfo.FQualifiedName := True;
end;
end else begin
serInfo.FExternalName := serInfo.FName;
if ( trioNonQualifiedName in regItem.Options ) then begin
serInfo.FQualifiedName := True;
serInfo.FNameSpace := '';
end;
end;
if serInfo.QualifiedName then begin
serInfo.FReaderProc := ReaderInfoMap[ppi^.PropType^.Kind].Qualified;
serInfo.FWriterProc := WriterInfoMap[ppi^.PropType^.Kind].Qualified;
end else begin
serInfo.FReaderProc := ReaderInfoMap[ppi^.PropType^.Kind].Simple;
serInfo.FWriterProc := WriterInfoMap[ppi^.PropType^.Kind].Simple;
if Target.IsAttributeProperty(ppi^.Name) then
serInfo.FStyle := ssAttibuteSerialization
else
serInfo.FStyle := ssNodeSerialization;
end;
end;
end;
//Check for inherited properties declared in other namespace
@ -1409,6 +1496,259 @@ begin
end;
end;
{ TSimpleContentObjectSerializer }
procedure TSimpleContentObjectSerializer.Prepare(ATypeRegistry : TTypeRegistry);
var
thisRegItem, regItem : TTypeRegistryItem;
serArray : array of TPropSerializationInfo;
cl : TClass;
procedure InitPropItem(const APropInfo : PPropInfo);
var
regPropItem : TPropertyItem;
serInfo : TPropSerializationInfo;
st : TPropStoreType;
begin
st := IsStoredPropClass(cl,APropInfo);
if ( st in [pstAlways,pstOptional] ) then begin
regPropItem := regItem.FindProperty(APropInfo^.Name,pntInternalName);
serInfo := TPropSerializationInfo.Create();
serArray[APropInfo^.NameIndex] := serInfo;
serInfo.FName := APropInfo^.Name;
serInfo.FExternalName := serInfo.FName;
serInfo.FPersisteType := st;
serInfo.FPropInfo := APropInfo;
serInfo.FNameSpace := regItem.NameSpace;
serInfo.FStyle := ssAttibuteSerialization;
serInfo.FQualifiedName := True;
serInfo.FNameSpace := '';
if ( regPropItem <> nil ) then begin
serInfo.FExternalName := regPropItem.ExternalName;
if not ( trioNonQualifiedName in regPropItem.Options ) then begin
serInfo.FNameSpace := regItem.NameSpace;
serInfo.FQualifiedName := True;
end;
end;
if serInfo.QualifiedName then begin
serInfo.FReaderProc := ReaderInfoMap[APropInfo^.PropType^.Kind].Qualified;
serInfo.FWriterProc := WriterInfoMap[APropInfo^.PropType^.Kind].Qualified;
end else begin
serInfo.FReaderProc := ReaderInfoMap[APropInfo^.PropType^.Kind].Simple;
serInfo.FWriterProc := WriterInfoMap[APropInfo^.PropType^.Kind].Simple;
end;
end;
end;
procedure InheritedInitPropItem(const APropInfo : PPropInfo);
var
regPropItem : TPropertyItem;
serInfo : TPropSerializationInfo;
begin
serInfo := serArray[APropInfo^.NameIndex];
if ( serInfo <> nil ) then begin
regPropItem := regItem.FindProperty(APropInfo^.Name,pntInternalName);
if ( regPropItem <> nil ) then begin
if not ( trioNonQualifiedName in regPropItem.Options ) then begin
serInfo.FNameSpace := regItem.NameSpace;
serInfo.FQualifiedName := True;
end;
end else begin
if ( thisRegItem.NameSpace <> regItem.NameSpace ) then begin
if ( serInfo.FNameSpace <> '' ) then begin
serInfo.FNameSpace := regItem.NameSpace;
serInfo.FQualifiedName := True;
serInfo.FReaderProc := ReaderInfoMap[APropInfo^.PropType^.Kind].Qualified;
serInfo.FWriterProc := WriterInfoMap[APropInfo^.PropType^.Kind].Qualified;
end;
end;
end;
end;
end;
var
locObjTypeData : PTypeData;
locTypeInfo : PTypeInfo;
c, i : PtrInt;
clPL : PPropList;
begin
FSerializationInfos.Clear();
locTypeInfo := PTypeInfo(Target.ClassInfo);
locObjTypeData := GetTypeData(locTypeInfo);
c := locObjTypeData^.PropCount;
if ( c > 0 ) then begin
clPL := nil;
SetLength(serArray,c);
try
FillChar(Pointer(serArray)^,SizeOf(TPropSerializationInfo)*c,#0);
cl := Target;
thisRegItem := ATypeRegistry.ItemByTypeInfo[locTypeInfo];
regItem := thisRegItem;
GetPropList(locTypeInfo,FRawPropList);
try
for i := 0 to Pred(c) do begin
InitPropItem(FRawPropList^[i]);
end;
//Check for inherited properties declared in other namespace
GetMem(clPL,c*SizeOf(Pointer));
cl := cl.ClassParent;
while ( cl <> nil ) and ( cl <> TBaseComplexSimpleContentRemotable ) do begin
c := GetTypeData(PTypeInfo(cl.ClassInfo))^.PropCount;
if ( c > 0 ) then begin
GetPropInfos(PTypeInfo(cl.ClassInfo),clPL);
regItem := ATypeRegistry.Find(PTypeInfo(cl.ClassInfo),True);
if ( regItem <> nil ) then begin
for i := 0 to Pred(c) do begin
InheritedInitPropItem(clPL^[i]);
end;
end;
end;
cl := cl.ClassParent;
end;
// Fill the list now
for i := 0 to Pred(Length(serArray)) do begin
if ( serArray[i] <> nil ) then begin
FSerializationInfos.Add(serArray[i]);
serArray[i] := nil;
end;
end;
except
for i := 0 to Pred(locObjTypeData^.PropCount) do
serArray[i].Free();
raise;
end;
finally
if ( clPL <> nil ) then
FreeMem(clPL,locObjTypeData^.PropCount*SizeOf(Pointer));
SetLength(serArray,0);
end;
end;
end;
function TSimpleContentObjectSerializer.FindInfo(const APropName: string): TPropSerializationInfo;
var
i : Integer;
begin
Result := nil;
if ( FSerializationInfos.Count > 0 ) then begin
for i := 0 to Pred(FSerializationInfos.Count) do begin
if SameText(APropName,TPropSerializationInfo(FSerializationInfos[i]).ExternalName) then begin
Result := TPropSerializationInfo(FSerializationInfos[i]);
Break;
end;
end;
end;
end;
procedure TSimpleContentObjectSerializer.UpdateExternalName(
const APropName,
AExtPropName : string
);
var
itm : TPropSerializationInfo;
begin
itm := FindInfo(APropName);
if ( itm <> nil ) then
itm.FExternalName := AExtPropName;
end;
constructor TSimpleContentObjectSerializer.Create(
ATargetClass : TBaseComplexSimpleContentRemotableClass;
ATypeRegistry : TTypeRegistry
);
begin
Assert(ATargetClass <> nil);
Assert(ATypeRegistry <> nil);
FTarget := ATargetClass;
FSerializationInfos := TObjectList.Create(True);
Prepare(ATypeRegistry);
end;
destructor TSimpleContentObjectSerializer.Destroy();
begin
if ( FRawPropList <> nil ) then
FreeMem(FRawPropList,GetTypeData(PTypeInfo(Target.ClassInfo))^.PropCount*SizeOf(Pointer));
FSerializationInfos.Free();
inherited Destroy();
end;
type
TBaseComplexSimpleContentRemotableCrack = class(TBaseComplexSimpleContentRemotable) end;
procedure TSimpleContentObjectSerializer.Read(
var AObject : TObject;
AStore : IFormatterBase;
var AName : string;
const ATypeInfo : PTypeInfo
);
var
oldSS : TSerializationStyle;
i, c : PtrInt;
locSerInfo : TPropSerializationInfo;
begin
oldSS := AStore.GetSerializationStyle();
if ( osoDontDoBeginRead in Options ) or ( AStore.BeginObjectRead(AName,ATypeInfo) >= 0 ) then begin
try
if AStore.IsCurrentScopeNil() then
Exit; // ???? FreeAndNil(AObject);
if not Assigned(AObject) then
AObject := Target.Create();
TBaseComplexSimpleContentRemotableCrack(AObject).LoadValue(AObject,AStore);
c := FSerializationInfos.Count;
if ( c > 0 ) then begin
AStore.SetSerializationStyle(ssAttibuteSerialization);
for i := 0 to Pred(c) do begin
locSerInfo := TPropSerializationInfo(FSerializationInfos[i]);
if ( not locSerInfo.ReaderProc(AObject,locSerInfo,AStore) ) and
( locSerInfo.PersisteType = pstAlways )
then begin
AStore.Error(SERR_ParamaterNotFound,[locSerInfo.ExternalName]);
end;
end;
end;
finally
if not ( osoDontDoBeginRead in Options ) then
AStore.EndScopeRead();
AStore.SetSerializationStyle(oldSS);
end;
end;
end;
procedure TSimpleContentObjectSerializer.Save(
AObject : TBaseRemotable;
AStore : IFormatterBase;
const AName : string;
const ATypeInfo : PTypeInfo
);
var
oldSS : TSerializationStyle;
i, c : PtrInt;
locSerInfo : TPropSerializationInfo;
begin
oldSS := AStore.GetSerializationStyle();
if not ( osoDontDoBeginWrite in Options ) then
AStore.BeginObject(AName,ATypeInfo);
try
if not Assigned(AObject) then begin
AStore.NilCurrentScope();
Exit;
end;
TBaseComplexSimpleContentRemotableCrack(AObject).SaveValue(AObject,AStore);
c := FSerializationInfos.Count;
if ( c > 0 ) then begin
AStore.SetSerializationStyle(ssAttibuteSerialization);
for i := 0 to Pred(c) do begin
locSerInfo := TPropSerializationInfo(FSerializationInfos[i]);
locSerInfo.WriterProc(AObject,locSerInfo,AStore);
end;
end;
finally
if not ( osoDontDoBeginWrite in Options ) then
AStore.EndScope();
AStore.SetSerializationStyle(oldSS);
end;
end;
{ TBaseComplexRemotableInitializer }
class function TBaseComplexRemotableInitializer.CanHandle(ATypeInfo : PTypeInfo) : Boolean;
@ -1434,6 +1774,31 @@ begin
end;
{$ENDIF TRemotableTypeInitializer_Initialize}
{ TSimpleContentObjectRemotableInitializer }
class function TSimpleContentObjectRemotableInitializer.CanHandle(ATypeInfo : PTypeInfo) : Boolean;
begin
Result := ( ATypeInfo <> nil ) and
( ATypeInfo^.Kind = tkClass ) and
GetTypeData(ATypeInfo)^.ClassType.InheritsFrom(TBaseComplexSimpleContentRemotable);
end;
class function TSimpleContentObjectRemotableInitializer.GetItemClass(
const ATypeInfo : PTypeInfo
) : TTypeRegistryItemClass;
begin
Result := TSimpleContentObjectRegistryItem;
end;
{$IFDEF TRemotableTypeInitializer_Initialize}
class function TSimpleContentObjectRemotableInitializer.Initialize(
ATypeInfo : PTypeInfo;
ARegistryItem : TTypeRegistryItem
) : Boolean;
begin
end;
{$ENDIF TRemotableTypeInitializer_Initialize}
{ TBaseComplexTypeRegistryItem }
procedure TBaseComplexTypeRegistryItem.Init();
@ -1462,4 +1827,43 @@ begin
Result := FSerializer;
end;
{ TSimpleContentObjectRegistryItem }
procedure TSimpleContentObjectRegistryItem.Init();
begin
inherited Init();
if ( FSerializer <> nil ) then
FreeAndNil(FSerializer);
FSerializer := TSimpleContentObjectSerializer.Create(TBaseComplexSimpleContentRemotableClass(GetTypeData(DataType)^.ClassType),Owner);
end;
destructor TSimpleContentObjectRegistryItem.Destroy();
begin
FSerializer.Free();
inherited Destroy();
end;
procedure TSimpleContentObjectRegistryItem.RegisterExternalPropertyName(
const APropName,
AExtPropName : string
);
begin
inherited RegisterExternalPropertyName(APropName, AExtPropName);
GetSerializer().UpdateExternalName(APropName,AExtPropName);
end;
procedure TSimpleContentObjectRegistryItem.SetPropertyOptions(
const APropName: string;
const AOptions: TTypeRegistryItemOptions
);
begin
inherited SetPropertyOptions(APropName,AOptions);
Init();
end;
function TSimpleContentObjectRegistryItem.GetSerializer() : TSimpleContentObjectSerializer;
begin
Result := FSerializer;
end;
end.

3
wst/trunk/synapse_http_protocol.pas
View File

@ -168,6 +168,9 @@ var
s : TBinaryString;
{$ENDIF}
begin
{$IFDEF WST_DBG}
TMemoryStream(ARequest).SaveToFile('request-1.log');
{$ENDIF}
FConnection.Document.Size := 0;
FConnection.Headers.Add('soapAction:' + SoapAction);
FConnection.Document.CopyFrom(ARequest,0);

2
wst/trunk/tests/test_suite/files/write_header_simple_content_2.xml
View File

@ -6,7 +6,7 @@
xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">
<SOAP-ENV:Header xmlns:ns1="urn:simple-content-header.sample">
<ns1:TSampleSimpleContentHeaderBlock_A>sample header simple content value</ns1:TSampleSimpleContentHeaderBlock_A>
<ns1:TSampleSimpleContentHeaderBlock_B ns1:intAtt="1210">another content</ns1:TSampleSimpleContentHeaderBlock_B>
<ns1:TSampleSimpleContentHeaderBlock_B intAtt="1210">another content</ns1:TSampleSimpleContentHeaderBlock_B>
</SOAP-ENV:Header>
<SOAP-ENV:Body>
<ns2:test_proc xmlns:ns2="TestService"/>

7
wst/trunk/tests/test_suite/test_soap_specific.pas
View File

@ -590,7 +590,7 @@ begin
locStream := TMemoryStream.Create();
try
ser.SaveToStream(locStream);
//locStream.SaveToFile(wstExpandLocalFileName('write_header_simple_content_2.xml'));
locStream.SaveToFile(wstExpandLocalFileName('write_header_simple_content_2.xml'));
locStream.Position := 0;
ReadXMLFile(locDoc,locStream);
ReadXMLFile(locExistDoc,wstExpandLocalFileName(TestFilesPath + 'write_header_simple_content_2.xml'));
@ -657,7 +657,7 @@ const
' xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/">' + sLineBreak +
' <SOAP-ENV:Header xmlns:ns1="urn:simple-content-header.sample">' + sLineBreak +
' <ns1:TSampleSimpleContentHeaderBlock_A SOAP-ENV:mustUnderstand="1">sample header simple content value</ns1:TSampleSimpleContentHeaderBlock_A>' + sLineBreak +
' <ns1:TSampleSimpleContentHeaderBlock_B ns1:intAtt="1210" SOAP-ENV:mustUnderstand="0">another content</ns1:TSampleSimpleContentHeaderBlock_B>' + sLineBreak +
' <ns1:TSampleSimpleContentHeaderBlock_B intAtt="1210" SOAP-ENV:mustUnderstand="1">another content</ns1:TSampleSimpleContentHeaderBlock_B>' + sLineBreak +
' </SOAP-ENV:Header>' + sLineBreak +
' <SOAP-ENV:Body>' + sLineBreak +
' <ns2:test_proc xmlns:ns2="TestService"/>' + sLineBreak +
@ -688,8 +688,9 @@ begin
CheckEquals('sample header simple content value',hdrA.Value,'Value');
CheckIs(cctx.GetHeader(1),TSampleSimpleContentHeaderBlock_B);
hdrB := TSampleSimpleContentHeaderBlock_B(cctx.GetHeader(1));
CheckEquals(0,hdrB.mustUnderstand,'mustUnderstand');
CheckEquals(1,hdrB.mustUnderstand,'mustUnderstand');
CheckEquals('another content',hdrB.Value,'Value');
CheckEquals(1210,hdrB.intAtt,'intAtt');
f.EndScopeRead();
finally
FreeAndNil(strm);

12
wst/trunk/tests/test_suite/testformatter_unit.pas
View File

@ -6474,15 +6474,27 @@ initialization
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(TClass_B),'TClass_B');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(TClass_Float),'TClass_Float');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt64SContent),'T_ComplexInt64SContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt64UContent),'T_ComplexInt64UContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt32SContent),'T_ComplexInt32SContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt32UContent),'T_ComplexInt32UContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt16SContent),'T_ComplexInt16SContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt16UContent),'T_ComplexInt16UContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt8SContent),'T_ComplexInt8SContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexInt8UContent),'T_ComplexInt8UContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexFloatExtendedContent),'T_ComplexFloatExtendedContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexFloatDoubleContent),'T_ComplexFloatDoubleContent');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexStringContent));
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexWideStringContent));
{$IFDEF WST_UNICODESTRING}
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(T_ComplexUnicodeStringContent));
{$ENDIF WST_UNICODESTRING}
TClass_CplxSimpleContent.RegisterAttributeProperty('Elt_Exemple');
GetTypeRegistry().Register(TEST_NAME_SPACE,TypeInfo(TClass_CplxSimpleContent),'TClass_CplxSimpleContent').RegisterExternalPropertyName('Elt_Exemple', 'published');

1
wst/trunk/tests/test_suite/wst_test_suite.lpi
View File

@ -238,7 +238,6 @@
</Parsing>
<CodeGeneration>
<Checks>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
</Checks>
</CodeGeneration>