david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
1871 lines
62 KiB
ObjectPascal
1871 lines
62 KiB
ObjectPascal
unit uROXMLSerializer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
|
|
Classes, uROSerializer, TypInfo, uROXMLIntf, uROTypes, SysUtils, FMTBcd;
|
|
|
|
const
|
|
// SOAP specifics
|
|
tag_Envelope = 'Envelope';
|
|
tag_Body = 'Body';
|
|
tag_Header = 'Header';
|
|
tag_Fault = 'Fault';
|
|
|
|
ns_Envelope = 'SOAP-ENV';
|
|
ns_Standard = 'xs';
|
|
ns_Custom = 'ro';
|
|
ns_xsi = 'xsi';
|
|
ns_xsd = 'xsd';
|
|
|
|
tag_HRef = 'href';
|
|
tag_Nil = 'xsi:nil';
|
|
tag_NilValue = 'true';
|
|
tag_Id = 'id';
|
|
|
|
// Misc
|
|
SOAP_DecimalSeperator = '.';
|
|
SOAP_BoolValues: array [Boolean] of string = ('false', 'true');
|
|
|
|
SOAP_DateFormat = 'yyyy-mm-dd';
|
|
SOAP_DateFormatLength = 10;
|
|
|
|
SOAP_DateTimeFormat = 'yyyy-mm-dd"T"hh":"nn":"ss';
|
|
SOAP_DateTimeFormatLength = 19;
|
|
|
|
SOAP_TimeFormat = 'hh":"nn":"ss';
|
|
SOAP_TimeFormatLength = 8;
|
|
|
|
// Data types signatures
|
|
dts_Array = 'SOAP-ENC:Array';
|
|
dts_Array2 = 'soapenc:Array';
|
|
dts_base64Binary = 'base64Binary';
|
|
|
|
|
|
type
|
|
{ Misc }
|
|
TROXMLSerializationOption = (
|
|
xsoWriteMultiRefArray, // for literal, use false
|
|
xsoWriteMultiRefObject, // for literal, use false
|
|
xsoSendUntyped, // for literal, use true
|
|
xsoStrictStructureFieldOrder,
|
|
xsoIgnoreStructureType,
|
|
xsoEncodedXML, // for literal, use false
|
|
xsoClientIdInWsdl,
|
|
xsoDocument, // for document, use true; if both doc & literal are true it uses wrapped arguments
|
|
xsoSplitServiceWsdls,
|
|
xsoExternalTypesAsReferences // This will emit "import" references to external resources in the wsdl and namespace references in the body of messages.
|
|
);
|
|
|
|
TROXMLSerializationOptions = set of TROXMLSerializationOption;
|
|
|
|
TXMLSerializationOption = TROXMLSerializationOption {$IFDEF DELPHI10UP}deprecated{$ENDIF};
|
|
TXMLSerializationOptions = TROXMLSerializationOptions {$IFDEF DELPHI10UP}deprecated{$ENDIF};
|
|
|
|
{ TROXMLSerializer }
|
|
TROXMLSerializer = class(TROSerializer)
|
|
private
|
|
fNode: IXMLNode;
|
|
fSerializationOptions: TROXMLSerializationOptions;
|
|
|
|
fBodyNode : IXMLNode;
|
|
fMaxRef : integer;
|
|
fRespNode : IXMLNode;
|
|
|
|
function BodyNode : IXMLNode;
|
|
function FindNode(const aName: string; ArrayElementId : integer): boolean;
|
|
function GetObject(const aName: string; ArrayElementId : integer): IXMLNode;
|
|
function FindSoapReference(subnode: IXMLNode): IXMLNode;
|
|
protected
|
|
{ Internal }
|
|
function GetRecordStrictOrder: Boolean; override;
|
|
procedure BeginWriteObject(const aName: string; aClass : TClass; anObject: TObject; var LevelRef : IUnknown;
|
|
var IsValidType : boolean; out IsAssigned:Boolean; ArrayElementId : integer = -1); override;
|
|
procedure EndWriteObject(const aName: string; aClass : TClass; anObject: TObject; const LevelRef : IUnknown); override;
|
|
procedure CustomWriteObject(const aName : string; aClass : TClass; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure CustomReadObject(const aName: string; aClass: TClass;var Ref; ArrayElementId: integer);override;
|
|
procedure BeginReadObject(const aName : string; aClass : TClass; var anObject : TObject; var LevelRef : IUnknown;
|
|
var IsValidType : boolean; ArrayElementId : integer = -1); override;
|
|
procedure EndReadObject(const aName : string; aClass : TClass; var anObject : TObject; const LevelRef : IUnknown); override; public
|
|
{ Writers }
|
|
procedure WriteInteger(const aName : string; anOrdType : TOrdType; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteInt64(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteEnumerated(const aName : string; anEnumTypeInfo : PTypeInfo; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteUTF8String(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteWideString(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteDateTime(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteDouble(const aName : string; aFloatType : TFloatType; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteVariant(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
procedure WriteDecimal(const aName: String; const Ref; ArrayElementId: Integer = -1); override;
|
|
procedure WriteGuid(const aName: String; const Ref; ArrayElementId: Integer = -1); override;
|
|
procedure WriteXml(const aName: String; const Ref; ArrayElementId: Integer = -1); override;
|
|
procedure WriteBinary(const aName : string; const Ref; ArrayElementId : integer = -1);override;
|
|
procedure WriteStruct(const aName : string; const Ref; ArrayElementId : integer = -1);override;
|
|
procedure WriteArray(const aName : string; const Ref; ArrayElementId : integer = -1);override;
|
|
procedure WriteException(const aName : string; const Ref; ArrayElementId : integer = -1); override;
|
|
|
|
{ Readers }
|
|
procedure ReadInteger(const aName : string; anOrdType : TOrdType; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadInt64(const aName : string; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadEnumerated(const aName : string; anEnumTypeInfo : PTypeInfo; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadUTF8String(const aName : string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1); override;
|
|
procedure ReadWideString(const aName : string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1); override;
|
|
procedure ReadDateTime(const aName : string; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadDouble(const aName : string; aFloatType : TFloatType; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadVariant(const aName : string; var Ref; ArrayElementId : integer = -1); override;
|
|
procedure ReadDecimal(const aName: String; var Ref; ArrayElementId: Integer = -1); override;
|
|
procedure ReadGuid(const aName: String; var Ref; ArrayElementId: Integer = -1); override;
|
|
procedure ReadXml(const aName: String; var Ref; ArrayElementId: Integer = -1); override;
|
|
procedure ReadBinary(const aName : string; var Ref; ArrayElementId : integer = -1);override;
|
|
function ReadStruct(const aName : string; aClass : TClass; var Ref; ArrayElementId : integer = -1): Boolean; override;
|
|
function ReadArray(const aName : string; aClass : TClass; var Ref; ArrayElementId : integer = -1): Boolean; override;
|
|
procedure ReadException(const aName : string; var Ref; ArrayElementId : integer = -1); override;
|
|
public
|
|
constructor Create(aStorageRef:pointer);
|
|
|
|
procedure SetStorageRef(aStorageRef:pointer);
|
|
function GetArrayElementName(anItemType : PTypeInfo; anItemReference: pointer): string; override;
|
|
|
|
property SerializationOptions : TROXMLSerializationOptions read fSerializationOptions write fSerializationOptions;
|
|
end;
|
|
|
|
const
|
|
RESERVED_WORD_PREFIX = '___';
|
|
|
|
function Unprefix(const AStr: String; const APrefix: String = RESERVED_WORD_PREFIX): String;
|
|
|
|
function XMLToObject(const someXML : string) : TROComplexType;
|
|
function ObjectToXML(anObject : TROComplexType;
|
|
const anObjectName : string = '') : string;
|
|
|
|
procedure SplitNodeName(const aNode : IXMLNode; out aNameSpace, aLocalName : string);
|
|
|
|
function SOAPDateTimeToDateTime(const aSOAPDate : string) : TDateTime;
|
|
function DateTimeToSOAPDateTime(aDateTime : TDateTime) : string;
|
|
|
|
function ExtractServerURL(const aFullURL : string) : string;
|
|
|
|
function SOAPStrToFloat(const aString: string): Extended;
|
|
|
|
function AddXMLChildNode(aParent : IXMLNode; const aName : string; const aNamespace: WideString = '') : IXMLNode;
|
|
function AddXMLAttribute(aNode : IXMLNode; const aName: string; const aValue : WideString) : IXMLNode;
|
|
procedure AddXMLTextValue(aNode : IXMLNode; const aValue : WideString);
|
|
|
|
function FindChildNode(aParent : IXMLNode; const aName : string; StartFrom : integer; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
function FindChildNodeByAttribute(aParent : IXMLNode; const anAttributeName, anAttributeValue : string) : IXMLNode;
|
|
function FindParentNode(aNode : IXMLNode; const aName : string; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
function FindAttribute(aNode : IXMLNode; const aName : string; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
function GetXMLTextValue(aNode : IXMLNode) : widestring;
|
|
|
|
{$IFDEF DELPHI7UP}
|
|
const SOAPLocale = 1033;
|
|
var SOAPFormatSettings : TFormatSettings;
|
|
{$ENDIF DELPHI7}
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF DELPHI5}Windows, {$ENDIF}
|
|
Math, uRORes, uROCompression, uROClasses, Variants, uROBinaryHelpers;
|
|
|
|
|
|
function ObjectToXML(anObject : TROComplexType;
|
|
const anObjectName : string = '') : string;
|
|
var objname : string;
|
|
doc : IXMLDocument;
|
|
begin
|
|
result := '';
|
|
|
|
if (anObjectName='') then objname := 'Object'
|
|
else objname := anObjectName;
|
|
|
|
doc := NewROXmlDocument;
|
|
doc.New(anObject.ClassName);
|
|
|
|
with TROXMLSerializer.Create(pointer(doc.DocumentNode)) do try
|
|
//with TROXMLSerializer.Create(doc.DocumentNode) do try
|
|
SerializationOptions := [xsoSendUntyped];
|
|
Write(anObject.ClassName, anObject.ClassInfo, anObject);
|
|
|
|
{$IFDEF RemObjects_OpenXML}
|
|
result := doc.XML; //mej - OpenXML seems to not behave the same way as MSDOM
|
|
{$ELSE}
|
|
result := doc.DocumentNode.XML;
|
|
{$ENDIF}
|
|
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
function XMLToObject(const someXML : string) : TROComplexType;
|
|
var clsname : string;
|
|
cls : TROComplexTypeClass;
|
|
doc : IXMLDocument;
|
|
ss : TStringStream;
|
|
begin
|
|
ss := TStringStream.Create(someXML);
|
|
ss.Position := 0;
|
|
try
|
|
doc := NewROXmlDocument;
|
|
doc.New;
|
|
doc.LoadFromStream(ss);
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
clsname := doc.DocumentNode.Name;
|
|
cls := FindROClass(clsname);
|
|
|
|
if (cls=NIL) then RaiseError(err_UnknownClass, [clsname]);
|
|
|
|
with TROXMLSerializer.Create(pointer(doc.DocumentNode)) do try
|
|
//with TROXMLSerializer.Create(doc.DocumentNode) do try
|
|
Read(clsname, cls.ClassInfo, result);
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
procedure SplitName(const aName : string; out aNameSpace, aLocalName : string);
|
|
var idx : integer;
|
|
begin
|
|
aNameSpace := '';
|
|
if (aName='') then begin
|
|
aLocalName := '';
|
|
Exit;
|
|
end
|
|
else aLocalName := aName;
|
|
|
|
idx := Pos(':', aName);
|
|
if (idx>0) then begin
|
|
aNameSpace := Copy(aName, 1, idx-1);
|
|
aLocalName := Copy(aName, idx+1, Length(aName)-idx);
|
|
end;
|
|
end;
|
|
|
|
// Required for a bug in OpenXML which never assigns correctly LocalName
|
|
procedure SplitNodeName(const aNode : IXMLNode; out aNameSpace, aLocalName : string);
|
|
begin
|
|
// SplitName(aNode.nodeName, aNameSpace, aLocalName)
|
|
SplitName(aNode.Name, aNameSpace, aLocalName)
|
|
end;
|
|
|
|
function SOAPStrToFloat(const aString: string): Extended;
|
|
begin
|
|
{$IFDEF DELPHI7UP}
|
|
Result := StrToFloat(aString,SOAPFormatSettings);// then
|
|
{$ELSE}
|
|
Result := StrToFloat(StringReplace(aString, '.', DecimalSeparator, []));
|
|
{$ENDIF}
|
|
//RaiseError(err_ErrorConvertingFloat, [aString]);
|
|
//Val(aString, Result, e);
|
|
//if (e<>0) then RaiseError(err_ErrorConvertingFloat, [aString, e]);
|
|
end;
|
|
|
|
function SOAPDateTimeToDateTime(const aSOAPDate : string) : TDateTime;
|
|
var year, month, day, hour, min, sec : word;
|
|
msec: double;
|
|
ldummy, i: Integer;
|
|
s: string;
|
|
begin
|
|
// This probabily will all change. See W3C specs for date/time
|
|
case Length(aSOAPDate) of
|
|
SOAP_DateFormatLength : begin {yyyy-mm-dd}
|
|
year := StrToInt(Copy(aSOAPDate,1,4));
|
|
month := StrToInt(Copy(aSOAPDate,6,2));
|
|
day := StrToInt(Copy(aSOAPDate,9,2));
|
|
result := EncodeDate(year, month, day);
|
|
end;
|
|
SOAP_TimeFormatLength : begin {hh:nn:ss}
|
|
hour := StrToInt(Copy(aSOAPDate,1,2));
|
|
min := StrToInt(Copy(aSOAPDate,4,2));
|
|
sec := StrToInt(Copy(aSOAPDate,7,2));
|
|
result := EncodeTime(hour, min, sec, 0);
|
|
end;
|
|
else {SOAP_DateTimeFormatLength : } begin {yyyy-mm-ddThh:nn:ss}
|
|
year := StrToInt(Copy(aSOAPDate,1,4));
|
|
month := StrToInt(Copy(aSOAPDate,6,2));
|
|
day := StrToInt(Copy(aSOAPDate,9,2));
|
|
hour := StrToInt(Copy(aSOAPDate,12,2));
|
|
min := StrToInt(Copy(aSOAPDate,15,2));
|
|
sec := StrToInt(Copy(aSOAPDate,18,2));
|
|
s := copy(aSOAPDate, 20, MaxInt);
|
|
if (Length(s) > 1) and (s[1] = '.') then begin
|
|
i := LastDelimiter('+-Z', s);
|
|
if i > 0 then begin
|
|
Val(Copy(s, 1, i -1), msec, ldummy);
|
|
delete(s, 1, i-1);
|
|
end else begin
|
|
Val(s, msec, ldummy);
|
|
s := '';
|
|
end;
|
|
msec := msec * (1.0 / 60.0 / 60.0 / 24);
|
|
end else
|
|
msec := 0;
|
|
|
|
result := EncodeDate(year, month, day);
|
|
// The code below is required! Do not adjust
|
|
if (result<0) then begin
|
|
result := result-EncodeTime(hour, min, sec, 0);
|
|
result := result - msec;
|
|
end else begin
|
|
result := result+EncodeTime(hour, min, sec, 0);
|
|
result := result + msec;
|
|
end;
|
|
if (Length(s) > 0) and ((s[1] = '+') or (s[1] = '-')) then begin
|
|
if s[1] = '-' then i := -1 else i := 1;
|
|
Delete(s,1,1);
|
|
if pos(':', s) > 0 then begin
|
|
hour := StrToInt(copy(s,1,Pos(':', s)-1));
|
|
delete(s,1,pos(':', s));
|
|
min := StrToInt(s);
|
|
end else begin
|
|
hour := StrToInt(s);
|
|
min := 0;
|
|
end;
|
|
if i = 1 then
|
|
Result := Result - (1.0 / 86400.0) * (min + 60 * hour) * 60
|
|
else
|
|
Result := Result + (1.0 / 86400.0) * (min + 60 * hour) * 60;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function DateTimeToSOAPDateTime(aDateTime : TDateTime) : string;
|
|
begin
|
|
result := FormatDateTime(SOAP_DateTimeFormat, aDateTime);
|
|
end;
|
|
|
|
function ExtractServerURL(const aFullURL : string) : string;
|
|
const ProtocolID = 'http://';
|
|
var p : integer;
|
|
begin
|
|
result := Trim(StringReplace(aFullURL, ProtocolID, '', [rfReplaceAll, rfIgnoreCase]));
|
|
p := LastDelimiter('/', result);
|
|
if (p>0)
|
|
then result := ProtocolID+Copy(result, 1, p)
|
|
else result := ProtocolID+result;
|
|
end;
|
|
|
|
function AddXMLChildNode(aParent : IXMLNode; const aName : string; const aNamespace: WideString = '') : IXMLNode;
|
|
begin
|
|
{result := aParent.ownerDocument.createElement(aName);
|
|
aParent.appendChild(result);}
|
|
result := aParent.Add(aName, aNamespace)
|
|
end;
|
|
|
|
function AddXMLAttribute(aNode : IXMLNode; const aName: string; const aValue : WideString) : IXMLNode;
|
|
begin
|
|
{result := aNode.ownerDocument.createAttribute(aName);
|
|
result.nodeValue := aValue;
|
|
aNode.attributes.setNamedItem(result);}
|
|
result := aNode.AddAttribute(aName, aValue);
|
|
end;
|
|
|
|
procedure AddXMLTextValue(aNode : IXMLNode; const aValue : widestring);
|
|
begin
|
|
//aNode.appendChild(aNode.ownerDocument.createTextNode(aValue));
|
|
aNode.Value := aValue
|
|
end;
|
|
|
|
function FindParentNode(aNode : IXMLNode; const aName : string; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
var ns, locname : string;
|
|
parent : IXMLNode;
|
|
begin
|
|
result := NIL;
|
|
while (aNode.Parent<>NIL) do begin
|
|
parent := aNode.Parent;
|
|
|
|
if IsOnlyLocalName then begin
|
|
SplitNodeName(parent, ns, locname);
|
|
if (CompareText(locname, aName)=0) then begin
|
|
result := parent;
|
|
Exit;
|
|
end;
|
|
end
|
|
else if (parent.Name=aName) then begin
|
|
result := parent;
|
|
Exit;
|
|
end;
|
|
|
|
aNode := parent;
|
|
end;
|
|
end;
|
|
|
|
function FindChildNode(aParent : IXMLNode; const aName : string; StartFrom : integer; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
var i, startidx : integer;
|
|
locname, ns : string;
|
|
item : IXMLNode;
|
|
begin
|
|
result := NIL;
|
|
|
|
with aParent do begin
|
|
// fix for arrays. I was always using the first item...
|
|
if (StartFrom>=0) then startidx := StartFrom
|
|
else startidx := 0;
|
|
|
|
for i := startidx to (childrenCount-1) do begin
|
|
item := Children[i];
|
|
|
|
if IsOnlyLocalName then begin
|
|
SplitNodeName(item, ns, locname);
|
|
|
|
if (CompareText(locname, aName)=0) then begin // I am ignoring XML case sensitivity here...
|
|
result := item;
|
|
Exit;
|
|
end;
|
|
|
|
// Moved down by AleF. This "patch" actually breaks regular webservices
|
|
// processing. Let's keep it here as an extreme measure for Amazon alike web services
|
|
{if (ns = '') and SameText(locname, 'return') then begin
|
|
Result := FindChildNode(item, aName, StartFrom, IsOnlyLocalName);
|
|
Exit;
|
|
end;}
|
|
end
|
|
else begin
|
|
if (item.Name=aName) then begin
|
|
result := item;
|
|
Exit;
|
|
end;
|
|
end
|
|
end
|
|
end;
|
|
end;
|
|
|
|
function FindChildNodeByAttribute(aParent : IXMLNode; const anAttributeName, anAttributeValue : string) : IXMLNode;
|
|
var i : integer;
|
|
//attr : IXMLNode;
|
|
item, item2 : IXMLNode;
|
|
//list : IXMLNodeList;
|
|
begin
|
|
result := NIL;
|
|
|
|
with aParent do
|
|
for i := 0 to (ChildrenCount-1) do begin
|
|
item := Children[i];
|
|
item2 := item.GetNodeByAttribute(anAttributeName, anAttributeValue);
|
|
|
|
if (item2<>NIL) then begin
|
|
result := item;
|
|
Exit;
|
|
end;
|
|
end
|
|
end;
|
|
|
|
function FindAttribute(aNode : IXMLNode; const aName : string; IsOnlyLocalName : boolean = FALSE) : IXMLNode;
|
|
//var i : integer;
|
|
//locname, ns : string;
|
|
begin
|
|
result := NIL;
|
|
result := aNode.GetAttributeByName(aName);
|
|
|
|
{with aNode do
|
|
for i := 0 to (AttributeCount-1) do begin
|
|
if IsOnlyLocalName then begin
|
|
SplitNodeName(attributes.item(i), ns, locname);
|
|
if (locname=aName) then begin
|
|
result := attributes.item(i);
|
|
Exit;
|
|
end;
|
|
end
|
|
else begin
|
|
if (attributes.item(i).nodeName=aName) then begin
|
|
result := attributes.item(i);
|
|
Exit;
|
|
end;
|
|
end
|
|
end}
|
|
end;
|
|
|
|
function GetXMLTextValue(aNode : IXMLNode) : WideString;
|
|
//var textnode : IXMLNode;
|
|
begin
|
|
//textnode := aNode.childNodes.item(0);
|
|
{if Assigned(textnode) and (textnode.hasChildNodes) and (textnode.nodeName='#text')
|
|
then result := textnode.textContent
|
|
else result := '';}
|
|
result := aNode.Value
|
|
end;
|
|
|
|
function SameText(A, B : string) : boolean;
|
|
begin
|
|
result := CompareText(a,b)=0
|
|
end;
|
|
|
|
function TypeInfoNameToSOAPType(aTypeInfo : PTypeInfo) : string;
|
|
begin
|
|
case aTypeInfo^.Kind of
|
|
tkEnumeration : begin
|
|
if (aTypeInfo=TypeInfo(boolean))
|
|
then result := ns_xsd+':boolean'
|
|
else result := ns_Custom+':'+aTypeInfo^.Name;
|
|
end;
|
|
tkInteger : begin
|
|
case GetTypeData(aTypeInfo)^.OrdType of
|
|
otSByte : result := ns_xsd+':byte';
|
|
otUByte : result := ns_xsd+':unsignedByte';
|
|
otSWord : result := ns_xsd+':short';
|
|
otUWord : result := ns_xsd+':unsignedShort';
|
|
otSLong : result := ns_xsd+':int';
|
|
otULong : result := ns_xsd+':unsignedInt';
|
|
end;
|
|
end;
|
|
tkInt64 : result := ns_xsd+':long';
|
|
// TODO: this wont work for DateTime's inside records or arrays
|
|
tkFloat : if (aTypeInfo=TypeInfo(TDateTime)) then result := ns_xsd+':dateTime'
|
|
else begin
|
|
case GetTypeData(aTypeInfo)^.FloatType of
|
|
ftSingle : result := ns_xsd+':float';
|
|
ftDouble : result := ns_xsd+':double';
|
|
ftExtended : result := ns_xsd+':double';
|
|
ftComp : result := ns_xsd+':double';
|
|
ftCurr : result := ns_xsd+':double';
|
|
end;
|
|
end;
|
|
tkWString,
|
|
tkLString,
|
|
tkString : result := ns_xsd+':string';
|
|
|
|
tkClass :
|
|
begin
|
|
if aTypeInfo = typeinfo(Binary) then
|
|
result := ns_xsd+':'+dts_base64Binary
|
|
else
|
|
result := ns_Custom+':'+aTypeInfo^.Name;
|
|
end;
|
|
tkVariant:
|
|
begin
|
|
if aTypeInfo = typeinfo(TDecimalVariant) then result := ns_xsd+':decimal' else
|
|
result := ns_xsd+':anyType';
|
|
end;
|
|
tkInterface:
|
|
result := ns_xsd+':any';
|
|
end;
|
|
|
|
end;
|
|
|
|
function VarTypeNameToSOAPType(aVarType : TVarType) : string;
|
|
begin
|
|
result := '';
|
|
case aVarType of
|
|
varBoolean : result := ns_xsd+':boolean';
|
|
varInteger : result := ns_xsd+':int';
|
|
varWord : result := ns_xsd+':unsignedShort';
|
|
varSmallInt : result := ns_xsd+':short';
|
|
varByte : result := ns_xsd+':unsignedByte';
|
|
varShortInt : result := ns_xsd+':byte';
|
|
varSingle : result := ns_xsd+':float';
|
|
varDouble,
|
|
varCurrency : result := ns_xsd+':double';
|
|
varDate : result := ns_xsd+':dateTime';
|
|
varOleStr,
|
|
varString : result := ns_xsd+':string';
|
|
varLongWord : result := ns_xsd+':unsignedInt';
|
|
varInt64 : result := ns_xsd+':long';
|
|
varEmpty,
|
|
varNull: result := ns_xsd+':null';
|
|
else
|
|
if aVarType = VarFMTBcd then
|
|
result := ns_xsd +':decimal'
|
|
else
|
|
result := ns_Custom+':unknown';
|
|
end;
|
|
end;
|
|
|
|
function Unprefix(const AStr, APrefix: String): String;
|
|
var
|
|
L: Integer;
|
|
begin
|
|
L := Length(APrefix);
|
|
if StrLIComp(PChar(AStr), PChar(APrefix), Min(Length(AStr), L)) = 0 then
|
|
Result :=Copy(AStr, L + 1, MaxInt)
|
|
else
|
|
Result := AStr;
|
|
end;
|
|
|
|
{ TROXMLSerializer }
|
|
constructor TROXMLSerializer.Create(aStorageRef: pointer);
|
|
begin
|
|
inherited Create;
|
|
SetStorageRef(aStorageRef);
|
|
fSerializationOptions := [xsoWriteMultiRefArray, xsoWriteMultiRefObject];
|
|
end;
|
|
|
|
{$IFDEF DELPHI5}
|
|
function Supports(const Instance: IUnknown; const Intf: TGUID): Boolean; overload;
|
|
var lDummyInst:IUnknown;
|
|
begin
|
|
result := Supports(Instance, Intf, lDummyInst);
|
|
end;
|
|
{$ENDIF DELPHI5}
|
|
|
|
procedure TROXMLSerializer.SetStorageRef(aStorageRef : pointer);
|
|
begin
|
|
fNode := nil;
|
|
if Supports(IUnknown(aStorageRef), IXMLNode) then begin
|
|
//RaiseError('TROXMLSerializer: Not a valid IXMLNode reference',[]);
|
|
fBodyNode := NIL;
|
|
fRespNode := NIL;
|
|
fMaxRef := 0;
|
|
fNode := IXMLNode(aStorageRef);
|
|
end;
|
|
{fNode := aStorageRef;}
|
|
end;
|
|
|
|
procedure TROXMLSerializer.EndReadObject(const aName: string;
|
|
aClass : TClass; var anObject: TObject; const LevelRef : IUnknown);
|
|
begin
|
|
fNode := IXMLNode(pointer(LevelRef));
|
|
end;
|
|
|
|
procedure TROXMLSerializer.EndWriteObject(const aName: string;
|
|
aClass : TClass; anObject: TObject; const LevelRef : IUnknown);
|
|
begin
|
|
fNode := IXMLNode(pointer(LevelRef));
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadDateTime(const aName: string; var Ref; ArrayElementId : integer = -1);
|
|
var subnode : IXMLNode;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL)
|
|
then TDateTime(Ref) := SOAPDateTimeToDateTime(GetXMLTextValue(subnode))
|
|
else TDateTime(Ref) := 0;
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadEnumerated(const aName: string;
|
|
anEnumTypeInfo: PTypeInfo; var Ref; ArrayElementId : integer = -1);
|
|
var subnode : IXMLNode;
|
|
s, lTypeName : string;
|
|
lIndexInEnum: Integer;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL)
|
|
then begin
|
|
s := GetXMLTextValue(subnode);
|
|
lIndexInEnum := GetEnumValue(anEnumTypeInfo, s);
|
|
if lIndexInEnum = -1 then begin
|
|
lIndexInEnum := GetEnumValue(anEnumTypeInfo, anEnumTypeInfo.Name+'_'+s);
|
|
if lIndexInEnum = -1 then begin
|
|
lTypeName := anEnumTypeInfo^.Name;
|
|
if anEnumTypeInfo = typeinfo(Boolean) then begin
|
|
if s = '1' then begin
|
|
byte(Ref) := 1;
|
|
exit;
|
|
end
|
|
else if s = '0' then begin
|
|
byte(Ref) := 0;
|
|
exit;
|
|
end;
|
|
end;
|
|
RaiseError(Format('The value "-1" for parameter "%s" of "%s" type is invalid', [aName, lTypeName]));
|
|
end;
|
|
end;
|
|
byte(Ref) := lIndexInEnum;
|
|
end else begin
|
|
byte(Ref) := 0;
|
|
end;
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadDouble(const aName: string;
|
|
aFloatType: TFloatType; var Ref; ArrayElementId : integer = -1);
|
|
var
|
|
subnode : IXMLNode;
|
|
text: string;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL) then begin
|
|
text := GetXMLTextValue(subnode);
|
|
|
|
{$IFNDEF DELPHI7UP}
|
|
if DecimalSeparator <> '.' then
|
|
ReplaceChar(text, ['.'], DecimalSeparator);
|
|
{$ENDIF}
|
|
|
|
case aFloatType of
|
|
ftSingle : single(Ref) := SOAPStrToFloat(text);
|
|
ftDouble : double(Ref) := SOAPStrToFloat(text);
|
|
ftExtended : extended(Ref) := SOAPStrToFloat(text);
|
|
ftComp : comp(Ref) := SOAPStrToFloat(text);
|
|
ftCurr : currency(Ref) := SOAPStrToFloat(text);
|
|
end;
|
|
end else begin
|
|
case aFloatType of
|
|
ftSingle : single(Ref) := 0;
|
|
ftDouble : double(Ref) := 0;
|
|
ftExtended : extended(Ref) := 0;
|
|
ftComp : comp(Ref) := 0;
|
|
ftCurr : currency(Ref) := 0;
|
|
end;
|
|
end;
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadInt64(const aName: string; var Ref; ArrayElementId : integer = -1);
|
|
var subnode : IXMLNode;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL)
|
|
then int64(Ref) := StrToInt64(GetXMLTextValue(subnode))
|
|
else int64(Ref) := int64(0);
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadInteger(const aName: string;
|
|
anOrdType: TOrdType; var Ref; ArrayElementId : integer = -1);
|
|
var subnode : IXMLNode;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL) then
|
|
case anOrdType of
|
|
otSByte,
|
|
otUByte : byte(Ref) := StrToInt(GetXMLTextValue(subnode));
|
|
otSWord,
|
|
otUWord : word(Ref) := StrToInt(GetXMLTextValue(subnode));
|
|
otSLong,
|
|
otULong : integer(Ref) := StrToInt(GetXMLTextValue(subnode));
|
|
end
|
|
else
|
|
case anOrdType of
|
|
otSByte,
|
|
otUByte : byte(Ref) := 0;
|
|
otSWord,
|
|
otUWord : word(Ref) := 0;
|
|
otSLong,
|
|
otULong : integer(Ref) := 0;
|
|
end
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadUTF8String(const aName: string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1);
|
|
var subnode : IXMLNode;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL) then
|
|
string(Ref) := GetXMLTextValue(subnode)
|
|
else
|
|
string(Ref) := '';
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadWideString(const aName: string; var Ref; ArrayElementId : integer = -1; iMaxLength:integer=-1);
|
|
var subnode : IXMLNode;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL) then
|
|
widestring(Ref) := GetXMLTextValue(subnode)
|
|
else
|
|
widestring(Ref) := '';
|
|
//else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteDateTime(const aName: string; const Ref; ArrayElementId : integer = -1);
|
|
var newnode : IXMLNode;
|
|
begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:dateTime');
|
|
AddXMLTextValue(newnode, DateTimeToSOAPDateTime(TDateTime(Ref)));
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteEnumerated(const aName: string;
|
|
anEnumTypeInfo: PTypeInfo; const Ref; ArrayElementId : integer = -1);
|
|
var newnode : IXMLNode;
|
|
isbool : boolean;
|
|
val : string;
|
|
lEnumName: String;
|
|
begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
isbool := (anEnumTypeInfo.Name='Boolean');
|
|
|
|
lEnumName := anEnumTypeInfo^.Name;
|
|
if not (xsoSendUntyped in SerializationOptions) then begin
|
|
if isbool
|
|
then AddXMLAttribute(newnode, 'xsi:type', 'xsd:boolean')
|
|
else AddXMLAttribute(newnode, 'xsi:type', ns_Custom+':'+lEnumName);
|
|
end;
|
|
|
|
val := GetEnumName(anEnumTypeInfo, Ord(byte(Ref)));
|
|
if (Length(val) > Length(lEnumName) + 2) and
|
|
(Copy(val, 1, Length(lEnumName) + 1) = lEnumName + '_') then begin
|
|
val := Copy(val, Length(lEnumName) + 2, MaxInt);
|
|
end;
|
|
if isbool then val := LowerCase(val);
|
|
|
|
AddXMLTextValue(newnode, val); // TODO: check enums bigger than a byte!
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteDouble(const aName: string;
|
|
aFloatType: TFloatType; const Ref; ArrayElementId : integer = -1);
|
|
var src : pointer;
|
|
text, dtype : string;
|
|
newnode : IXMLNode;
|
|
begin
|
|
src := @Ref;
|
|
case aFloatType of
|
|
ftSingle : begin
|
|
text := FloatToStr(single(src^){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
|
|
{$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
|
|
dtype := 'float';
|
|
end;
|
|
ftDouble : begin
|
|
text := FloatToStr(double(src^){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
|
|
{$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
|
|
dtype := 'double';
|
|
end;
|
|
ftExtended : begin
|
|
text := FloatToStr(extended(src^){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
|
|
{$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
|
|
dtype := 'double';
|
|
end;
|
|
ftComp : begin
|
|
text := FloatToStr(comp(src^){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
|
|
{$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
|
|
dtype := 'double';
|
|
end;
|
|
ftCurr : begin
|
|
text := FloatToStr(currency(src^){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
|
|
{$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
|
|
dtype := 'double';
|
|
end;
|
|
end;
|
|
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:'+dtype);
|
|
AddXMLTextValue(newnode, text);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteInt64(const aName: string; const Ref; ArrayElementId : integer = -1);
|
|
var src : pointer;
|
|
text : string;
|
|
newnode : IXMLNode;
|
|
begin
|
|
src := @Ref;
|
|
text := IntToStr(int64(src^));
|
|
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:long');
|
|
AddXMLTextValue(newnode, text);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteInteger(const aName: string;
|
|
anOrdType: TOrdType; const Ref; ArrayElementId : integer = -1);
|
|
var src : pointer;
|
|
text, dtype : string;
|
|
newnode : IXMLNode;
|
|
begin
|
|
src := @Ref;
|
|
case anOrdType of
|
|
otSByte : begin
|
|
text := IntToStr(shortint(src^));
|
|
dtype := 'byte';
|
|
end;
|
|
otUByte : begin
|
|
text := IntToStr(byte(src^));
|
|
dtype := 'unsignedByte';
|
|
end;
|
|
otSWord : begin
|
|
text := IntToStr(smallint(src^));
|
|
dtype := 'short';
|
|
end;
|
|
otUWord : begin
|
|
text := IntToStr(word(src^));
|
|
dtype := 'unsignedShort';
|
|
end;
|
|
otSLong : begin
|
|
text := IntToStr(integer(src^));
|
|
dtype := 'int';
|
|
end;
|
|
otULong : begin
|
|
text := IntToStr(integer(src^));
|
|
dtype := 'unsignedInt';
|
|
end;
|
|
end;
|
|
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:'+dtype);
|
|
AddXMLTextValue(newnode, text);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteUTF8String(const aName: string; const Ref; ArrayElementId : integer = -1);
|
|
var newnode : IXMLNode;
|
|
begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:string');
|
|
AddXMLTextValue(newnode, string(Ref));
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteWideString(const aName: string; const Ref; ArrayElementId : integer = -1);
|
|
var newnode : IXMLNode;
|
|
begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
AddXMLAttribute(newnode, 'xsi:type', 'xsd:string');
|
|
AddXMLTextValue(newnode, WideString(Ref));
|
|
|
|
newnode.Value := newnode.Value;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.BeginReadObject(const aName: string;
|
|
aClass : TClass; var anObject: TObject; var LevelRef : IUnknown; var IsValidType : boolean; ArrayElementId : integer = -1);
|
|
var cnt : integer;
|
|
lNilAttr, hrefattr : IXMLNode;
|
|
id : string;
|
|
clsnme, namespc, clstype : string;
|
|
lActualClass : TROComplexTypeClass;
|
|
begin
|
|
inherited;
|
|
|
|
if fRespNode = nil then
|
|
fRespNode := fNode;
|
|
|
|
LevelRef := fNode;
|
|
|
|
fnode := GetObject(aName, ArrayElementId);
|
|
|
|
fnode := FindSoapReference(fnode);
|
|
|
|
if (fNode=NIL) then begin
|
|
// No such node found
|
|
anObject := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
lNilAttr := fNode.GetAttributeByName(tag_Nil);
|
|
if Assigned(lNilAttr) and (lNilAttr.Value = tag_NilValue) then begin
|
|
anObject := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
hrefattr := fNode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
fNode := FindChildNodeByAttribute(BodyNode, tag_Id, id);
|
|
if fNode = nil then
|
|
fNode := FindChildNodeByAttribute(fRespNode, tag_Id, id);
|
|
end;
|
|
|
|
if aClass.InheritsFrom(TStream) then begin
|
|
anObject := TROBinaryMemoryStream.Create;
|
|
IsValidType := TRUE;
|
|
end
|
|
|
|
else if aClass.InheritsFrom(EROException) then begin
|
|
// Does nothing here
|
|
IsValidType := TRUE;
|
|
end
|
|
|
|
else if IsValidType then begin
|
|
clstype := VarToStr(fNode.GetAttributeValue('xsi:type', aClass.ClassName));
|
|
if (clstype = dts_Array) or (clstype = dts_Array2) then begin
|
|
//For arrays this attribute does't contain actual class name.
|
|
anObject := TROComplexTypeClass(aClass).Create;
|
|
end else begin
|
|
if xsoIgnoreStructureType in fSerializationOptions then begin
|
|
anObject := TROComplexTypeClass(aClass).Create;
|
|
end
|
|
else begin
|
|
SplitName(clstype, namespc, clsnme);
|
|
lActualClass := FindROClass(clsnme);
|
|
|
|
if not Assigned(lActualClass) then RaiseError(err_UnknownClassInStream,[clsnme]);
|
|
if not lActualClass.InheritsFrom(aClass) then RaiseError(err_UnexpectedClassInStream,[clsnme,aClass.ClassName]);
|
|
anObject := lActualClass.Create;
|
|
end;
|
|
end;
|
|
|
|
if (anObject is TROArray) then begin
|
|
cnt := fNode.ChildrenCount;
|
|
TROArray(anObject).Resize(cnt);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetNamespace(aClass: TClass; aInst: Tobject): string;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if aInst is TROComplexType then aClass := aInst.ClassType;
|
|
if (aClass <> nil) and (aClass.InheritsFrom(TROComplexType)) or (aClass = TROComplexType) then begin
|
|
for i := TROComplexTypeClass(aClass).GetAttributeCount -1 downto 0 do begin
|
|
if TROComplexTypeClass(aClass).GetAttributeName(i) = 'ImportedFromNamespace' then begin
|
|
result := TROComplexTypeClass(aClass).GetAttributeValue(i);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
result := '';
|
|
end;
|
|
|
|
procedure TROXMLSerializer.BeginWriteObject(const aName: string;
|
|
aClass : TClass; anObject: TObject; var LevelRef : IUnknown; var IsValidType : boolean; out IsAssigned:Boolean; ArrayElementId : integer = -1);
|
|
var id : string;
|
|
refnode : IXMLNode;
|
|
xsiattr : IXMLNode;
|
|
lName: String;
|
|
begin
|
|
lName := Unprefix(aName);
|
|
|
|
inherited BeginWriteObject(lName, aClass, anObject, LevelRef, IsValidType, IsAssigned, ArrayElementId);
|
|
|
|
if fRespNode = nil then
|
|
fRespNode := fNode;
|
|
|
|
IsAssigned := Assigned(anObject);
|
|
|
|
if aClass.InheritsFrom(TStream) then begin
|
|
LevelRef := fNode;
|
|
fNode := AddXMLChildNode(fNode, lName);
|
|
|
|
if Assigned(anObject) then begin
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', 'xsd:'+dts_base64Binary);
|
|
IsValidType := TRUE;
|
|
end
|
|
else begin
|
|
AddXMLAttribute(fNode, tag_Nil, tag_NilValue);
|
|
end;
|
|
end
|
|
else if IsValidType then begin // It is then a TROComplexType
|
|
|
|
LevelRef := fNode;
|
|
|
|
if ((aClass.InheritsFrom(TROArray) and (xsoWriteMultiRefArray in SerializationOptions)) or
|
|
(not aClass.InheritsFrom(TROArray)) and (xsoWriteMultiRefObject in SerializationOptions)) then begin
|
|
|
|
if Assigned(anObject) then begin
|
|
id := IntToStr(fMaxRef);
|
|
Inc(fMaxRef);
|
|
|
|
{refnode := fNode;
|
|
|
|
fNode := AddXMLChildNode(fRespNode, ns_Custom+':'+anObject.ClassName);
|
|
AddXMLAttribute(fNode, tag_Id, id);
|
|
|
|
refnode := AddXMLChildNode(refnode, lName);
|
|
AddXMLAttribute(refnode, tag_href, '#'+id);}
|
|
|
|
if xsoExternalTypesAsReferences in SerializationOptions then
|
|
refnode := AddXMLChildNode(fNode, lName, GetNamespace(aClass, AnObject))
|
|
else
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_href, '#'+id);
|
|
|
|
fNode := AddXMLChildNode(BodyNode, ns_Custom+':'+anObject.ClassName);
|
|
AddXMLAttribute(fNode, tag_Id, id);
|
|
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
if (anObject is TROArray) then begin
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', dts_Array);
|
|
//id := ns_Custom+':'+anObject.ClassName+'['+IntToStr(TROArray(anObject).Count)+']';
|
|
id := TypeInfoNameToSOAPType(TROArray(anObject).GetItemType)+'['+IntToStr(TROArray(anObject).Count)+']';
|
|
AddXMLAttribute(fNode, 'SOAP-ENC:arrayType', id);
|
|
end
|
|
else xsiattr := AddXMLAttribute(fNode, 'xsi:type', ns_Custom+':'+anObject.ClassName);
|
|
end
|
|
else begin
|
|
if xsoExternalTypesAsReferences in SerializationOptions then
|
|
refnode := AddXMLChildNode(fNode, lName, GetNamespace(aClass, anObject))
|
|
else
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_Nil, tag_NilValue);
|
|
end;
|
|
end
|
|
|
|
else begin
|
|
if xsoExternalTypesAsReferences in SerializationOptions then
|
|
fnode := AddXMLChildNode(fNode, lName, GetNamespace(aClass, anObject))
|
|
else
|
|
fNode := AddXMLChildNode(fNode, lName);
|
|
|
|
if not (xsoSendUntyped in SerializationOptions) then begin
|
|
if (anObject is TROArray) then begin
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', dts_Array);
|
|
//id := ns_Custom+':'+anObject.ClassName+'['+IntToStr(TROArray(anObject).Count)+']';
|
|
id := TypeInfoNameToSOAPType(TROArray(anObject).GetItemType)+'['+IntToStr(TROArray(anObject).Count)+']';
|
|
AddXMLAttribute(fNode, 'SOAP-ENC:arrayType', id);
|
|
end
|
|
else xsiattr := AddXMLAttribute(fNode, 'xsi:type', ns_Custom+':'+anObject.ClassName);
|
|
end
|
|
end
|
|
end;
|
|
|
|
//if (fNode<>NIL) and not IsAssigned
|
|
//then AddXMLAttribute(fNode, 'xsi:nil', 'true');
|
|
end;
|
|
|
|
procedure TROXMLSerializer.CustomReadObject(const aName: string;
|
|
aClass : TClass; var Ref; ArrayElementId: integer);
|
|
var obj : TObject absolute Ref;
|
|
ss : TStringStream;
|
|
begin
|
|
inherited;
|
|
if Assigned(obj) then begin
|
|
|
|
if (obj is TStream) then begin
|
|
ss := TStringStream.Create(fNode.Value);
|
|
try
|
|
DecodeStream(ss, TMemoryStream(obj));
|
|
TMemoryStream(obj).Position := 0;
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.CustomWriteObject(const aName: string;
|
|
aClass : TClass; const Ref; ArrayElementId : integer = -1);
|
|
var obj : TObject absolute Ref;
|
|
ss : TStringStream;
|
|
begin
|
|
inherited CustomWriteObject(Unprefix(aName), aClass, Ref, ArrayElementId);
|
|
if Assigned(obj) then begin
|
|
|
|
if (obj is TStream) then begin
|
|
ss := TStringStream.Create('');
|
|
try
|
|
TStream(obj).Position := 0;
|
|
EncodeStream(TStream(obj), ss);
|
|
AddXMLTextValue(fNode, ss.DataString);
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.BodyNode: IXMLNode;
|
|
begin
|
|
if (fBodyNode=NIL) then fBodyNode := FindParentNode(fNode, tag_Body, TRUE);
|
|
result := fBodyNode;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadVariant(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var s,
|
|
vartypestr,
|
|
varnamespcstr : string;
|
|
subnode : IXMLNode;
|
|
|
|
lIntegerValue:integer;
|
|
{$IFNDEF DELPHI5}
|
|
lShortIntValue:shortint;
|
|
lSmallIntValue: Smallint;
|
|
//lInt64Value:Int64;
|
|
{$ENDIF DELPHI5}
|
|
lByteValue:byte;
|
|
lBoolValue: boolean;
|
|
lDoubleValue:double;
|
|
lSingleValue:single;
|
|
//lCurrencyValue:currency;
|
|
lWordValue : word;
|
|
lStringValue: widestring;
|
|
lDateTimeValue : TDateTime;
|
|
begin
|
|
subnode := GetObject(aName, ArrayElementId);
|
|
|
|
subnode := FindSoapReference(subnode);
|
|
|
|
if (subnode<>NIL) then begin
|
|
// Determines the type of the value, if specified. Defaults to string.
|
|
s := subnode.GetAttributeValue('xsi:empty', '');
|
|
if s = '1' then begin
|
|
Variant(ref) := Unassigned;
|
|
exit;
|
|
end;
|
|
s := subnode.GetAttributeValue('xsi:null', '');
|
|
if s = '1' then begin
|
|
Variant(ref) := null
|
|
end
|
|
else begin
|
|
s := subnode.GetAttributeValue('xsi:type', 'xsd:string');
|
|
SplitName(s, varnamespcstr, vartypestr);
|
|
|
|
// Returns the right type of variant
|
|
if SameText(vartypestr, 'string') then begin
|
|
ReadWideString(aName, lStringValue, ArrayElementId);
|
|
Variant(Ref) := lStringValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'float') then begin
|
|
ReadDouble(aName, ftSingle, lSingleValue, ArrayElementId);
|
|
Variant(Ref) := lSingleValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'double') then begin
|
|
ReadDouble(aName, ftDouble, lDoubleValue, ArrayElementId);
|
|
Variant(Ref) := lDoubleValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'byte') then begin
|
|
ReadInteger(aName, otSByte, lShortIntValue, ArrayElementId);
|
|
Variant(Ref) := lShortIntValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'unsignedByte') then begin
|
|
ReadInteger(aName, otUByte, lByteValue, ArrayElementId);
|
|
Variant(Ref) := lByteValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'short') then begin
|
|
ReadInteger(aName, otSWord, lSmallIntValue, ArrayElementId);
|
|
Variant(Ref) := lSmallIntValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'unsignedShort') then begin
|
|
ReadInteger(aName, otUWord, lWordValue, ArrayElementId);
|
|
Variant(Ref) := lWordValue;
|
|
end
|
|
|
|
else if (SameText(vartypestr, 'int') or SameText(vartypestr, 'unsignedInt')) then begin
|
|
ReadInteger(aName, otSLong, lIntegerValue, ArrayElementId);
|
|
Variant(Ref) := lIntegerValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'boolean') then begin
|
|
ReadEnumerated(aName, TypeInfo(boolean), lBoolValue, ArrayElementId);
|
|
Variant(Ref) := lBoolValue;
|
|
end
|
|
|
|
else if SameText(vartypestr, 'dateTime') then begin
|
|
ReadDateTime(aName, lDateTimeValue, ArrayElementId);
|
|
Variant(Ref) := lDateTimeValue;
|
|
end
|
|
end;
|
|
end
|
|
else RaiseError(err_ParameterNotFound, [aName]);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteVariant(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var vtype : integer;
|
|
varvalue : Variant;
|
|
|
|
lIntegerValue:integer;
|
|
{$IFNDEF DELPHI5}
|
|
lShortIntValue:shortint;
|
|
lSmallIntValue: Smallint;
|
|
//lInt64Value:Int64;
|
|
{$ENDIF DELPHI5}
|
|
lByteValue:byte;
|
|
lBoolValue: boolean;
|
|
lDoubleValue:double;
|
|
lSingleValue:single;
|
|
lCurrencyValue:currency;
|
|
lWideString: widestring;
|
|
newnode: IXMLNode;
|
|
begin
|
|
varvalue := Variant(Ref);
|
|
vtype := VarType(Variant(Ref));
|
|
|
|
{ Simple types }
|
|
case vtype of
|
|
varEmpty:
|
|
begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
AddXMLAttribute(newnode, 'xsi:empty', '1');
|
|
end;
|
|
varNull,varError:begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
AddXMLAttribute(newnode, 'xsi:null', '1');
|
|
end;
|
|
{$IFNDEF DELPHI5}
|
|
varShortInt:begin { 2, 10, 12 }
|
|
lShortIntValue := varvalue;
|
|
WriteInteger(aName, otSByte, lShortIntValue, ArrayElementId);
|
|
end;
|
|
varSmallInt,
|
|
varWord : begin
|
|
lSmallIntValue := varvalue;
|
|
WriteInteger(aName, otSWord, lSmallIntValue, ArrayElementId); // Suspicious... This might be wrong
|
|
end;
|
|
{$ENDIF DELPHI5}
|
|
{$IFNDEF DELPHI5}varLongWord,{$ENDIF DELPHI5}
|
|
varInteger:begin { 3, 13 }
|
|
lIntegerValue := varvalue;
|
|
WriteInteger(aName, otSLong, lIntegerValue, ArrayElementId);
|
|
end;
|
|
varSingle:begin { 4 }
|
|
lSingleValue := varvalue;
|
|
WriteDouble(aName, ftSingle, lSingleValue, ArrayElementId);
|
|
end;
|
|
varDouble:begin { 5 }
|
|
lDoubleValue := varvalue;
|
|
WriteDouble(aName, ftDouble, lDoubleValue, ArrayElementId);
|
|
end;
|
|
varDate:begin { 7 } // This must be handled differently in SOAP!
|
|
lDoubleValue := varvalue;
|
|
WriteDateTime(aName, lDoubleValue, ArrayElementId);
|
|
end;
|
|
varCurrency:begin { 6 }
|
|
lCurrencyValue := varvalue;
|
|
WriteDouble(aName, ftCurr, lCurrencyValue, ArrayElementId);
|
|
end;
|
|
varBoolean:begin { B }
|
|
lBoolValue:= varvalue;
|
|
WriteEnumerated(aName, TypeInfo(boolean), lBoolValue, ArrayElementId);
|
|
end;
|
|
varByte:begin { 11 }
|
|
lByteValue := varvalue;
|
|
WriteInteger(aName, otUByte, lByteValue, ArrayElementId);
|
|
end;
|
|
{$IFNDEF DELPHI5}
|
|
(* varInt64:begin { 14 }
|
|
NotSupported('');
|
|
end;*)
|
|
{$ENDIF DELPHI5}
|
|
varOleStr,varString:begin { 8, 100 }
|
|
lWideString := varvalue;
|
|
WriteWideString(aName, lWideString, ArrayElementId);
|
|
end;
|
|
else NotSupported(Format(err_UnsupportedVariantType, [VarType(varvalue)]));
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.GetArrayElementName(
|
|
anItemType: PTypeInfo; anItemReference: pointer): string;
|
|
var tn: string;
|
|
begin
|
|
case anItemType.Kind of
|
|
tkClass : begin
|
|
if anItemReference = nil then result := anItemType^.Name else result := TObject(anItemReference).ClassName;
|
|
end;
|
|
tkVariant :
|
|
begin
|
|
tn := VarTypeNameToSOAPType(VarType(Variant(anItemReference^)));
|
|
result := Copy(tn, Pos(':', tn)+1, MaxInt);
|
|
end;
|
|
else begin
|
|
tn := TypeInfoNameToSOAPType(anItemType);
|
|
result := Copy(tn, Pos(':', tn)+1, MaxInt);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.GetRecordStrictOrder: Boolean;
|
|
begin
|
|
Result := xsoStrictStructureFieldOrder in fSerializationOptions;
|
|
end;
|
|
|
|
function TROXMLSerializer.FindSoapReference(subnode: IXMLNode): IXMLNode;
|
|
var
|
|
hrefattr: IXMLNode;
|
|
id: string;
|
|
begin
|
|
result := subnode;
|
|
if subnode = nil then
|
|
exit;
|
|
hrefattr := subnode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
while subnode <> nil do begin
|
|
result := FindChildNodeByAttribute(subnode, tag_Id, id);
|
|
if result <> nil then break;
|
|
subnode := subnode.Parent;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.GetObject(const aName: string; ArrayElementId : integer): IXMLNode;
|
|
begin
|
|
if (ArrayElementId>=0)
|
|
then result := fNode.Children[ArrayElementId]
|
|
else result := FindChildNode(fNode, Unprefix(aName), ArrayElementId,TRUE);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadXml(const aName: String; var Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
w: WideString;
|
|
doc: IXMLDocument;
|
|
node: IXMLNode;
|
|
begin
|
|
node := GetObject(aName, ArrayElementID);
|
|
if (xsoEncodedXML in SerializationOptions) or (node = nil) or (node.FirstChild = nil) or (Node.FirstChild.name = '#text') then begin
|
|
ReadWideString(aName, w, ArrayElementId);
|
|
if w = '' then
|
|
IXMLNode(Ref) := nil
|
|
else begin
|
|
doc := NewROXmlDocument;
|
|
doc.New;
|
|
doc.XML := w;
|
|
IXMLNode(Ref) := doc.DocumentNode;
|
|
end;
|
|
end else begin
|
|
if node = nil then IXMLNode(Ref) := nil else begin
|
|
node := Node.FirstChild;
|
|
if node = nil then begin
|
|
IXMLNode(Ref) := nil;
|
|
end else begin
|
|
doc := NewROXmlDocument;
|
|
doc.New;
|
|
doc.XML := node.XML;
|
|
IXMLNode(Ref) := doc.DocumentNode;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteXml(const aName: String; const Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
w: WideString;
|
|
newnode: IXMLNode;
|
|
begin
|
|
if (xsoEncodedXML in SerializationOptions) then begin
|
|
if IXMLNode(Ref) = nil then
|
|
w := ''
|
|
else
|
|
w := IXMLNode(Ref).XML;
|
|
WriteWideString(aName, w, ArrayElementId);
|
|
end else begin
|
|
newnode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if IXMLNode(Ref) <> nil then begin
|
|
newnode.AddXml(IXMLNode(Ref).XML);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadDecimal(const aName: String; var Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
ReadUTF8String(aName, s, ArrayElementId);
|
|
if DecimalSeparator <> '.' then s := StringReplace(s, '.', DecimalSeparator, []);
|
|
Variant(Ref) := BCDToVariant(StrToBcd(s));
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadGuid(const aName: String; var Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
ReadUTF8String(aName, s, ArrayElementId);
|
|
if Copy(s,1,1) <> '{' then s := '{'+s+'}';
|
|
string(Ref) := s;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteDecimal(const aName: String; const Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
s := BcdToStr(VariantToBCD(variant(Ref)));
|
|
if DecimalSeparator <> '.' then s := StringReplace(s, DecimalSeparator, '.', []); // delphi has no way to format a bcd with a specific format
|
|
WriteUTF8String(aName, s, ArrayElementId);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteGuid(const aName: String; const Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
s := GuidToString(StringToGUID(string(Ref)));
|
|
s := copy(s,2,length(s) -2); // remove curlies
|
|
WriteUTF8String(aName, s, ArrayElementId);
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadBinary(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : Binary absolute Ref;
|
|
ss : TStringStream;
|
|
LevelRef: IXMLNode;
|
|
begin
|
|
LevelRef := fNode;
|
|
try
|
|
if FindNode(aName, ArrayElementId) then begin
|
|
if not Assigned(obj) then obj:= Binary.Create;
|
|
ss := TStringStream.Create(fNode.Value);
|
|
try
|
|
obj.Clear;
|
|
DecodeStream(ss, TMemoryStream(obj));
|
|
TMemoryStream(obj).Position := 0;
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
end
|
|
else
|
|
Obj := nil;
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteBinary(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : Binary absolute Ref;
|
|
ss : TStringStream;
|
|
LevelRef: IXMLNode;
|
|
begin
|
|
LevelRef := fNode;
|
|
//BeginWriteObject
|
|
{ TODO -oek : BeginWriteObject }
|
|
fNode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if Assigned(obj) then begin
|
|
if not (xsoSendUntyped in SerializationOptions) then AddXMLAttribute(fNode, 'xsi:type', 'xsd:'+dts_base64Binary);
|
|
ss := TStringStream.Create('');
|
|
try
|
|
obj.Position := 0;
|
|
EncodeStream(obj, ss);
|
|
AddXMLTextValue(fNode, ss.DataString);
|
|
finally
|
|
ss.Free;
|
|
end;
|
|
end
|
|
else
|
|
AddXMLAttribute(fNode, tag_Nil, tag_NilValue);
|
|
fNode := LevelRef;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteArray(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : TROArray absolute Ref;
|
|
LevelRef: IXmlNode;
|
|
id : string;
|
|
refnode : IXMLNode;
|
|
xsiattr : IXMLNode;
|
|
lName: String;
|
|
begin
|
|
LevelRef := fNode;
|
|
try
|
|
lName := Unprefix(aName);
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
LevelRef := fNode;
|
|
if (xsoWriteMultiRefArray in SerializationOptions) then begin
|
|
if Assigned(obj) then begin
|
|
id := IntToStr(fMaxRef);
|
|
Inc(fMaxRef);
|
|
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_href, '#'+id);
|
|
|
|
fNode := AddXMLChildNode(BodyNode, ns_Custom+':'+obj.ClassName);
|
|
AddXMLAttribute(fNode, tag_Id, id);
|
|
|
|
if not (xsoSendUntyped in SerializationOptions) then begin
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', dts_Array);
|
|
id := TypeInfoNameToSOAPType(obj.GetItemType)+'['+IntToStr(obj.Count)+']';
|
|
AddXMLAttribute(fNode, 'SOAP-ENC:arrayType', id);
|
|
end;
|
|
end
|
|
else begin
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_Nil, tag_NilValue);
|
|
end;
|
|
end
|
|
else begin
|
|
fNode := AddXMLChildNode(fNode, lName);
|
|
if not (xsoSendUntyped in SerializationOptions) then begin
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', dts_Array);
|
|
id := TypeInfoNameToSOAPType(obj.GetItemType)+'['+IntToStr(obj.Count)+']';
|
|
AddXMLAttribute(fNode, 'SOAP-ENC:arrayType', id);
|
|
end
|
|
end;
|
|
if Assigned(Obj) then Obj.WriteComplex(Self);
|
|
finally
|
|
fNode := IXMLNode(LevelRef);
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteStruct(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : TROComplexType absolute Ref;
|
|
LevelRef: IXmlNode;
|
|
id : string;
|
|
refnode : IXMLNode;
|
|
xsiattr : IXMLNode;
|
|
lName: String;
|
|
begin
|
|
LevelRef:=fNode;
|
|
try
|
|
lName := Unprefix(aName);
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
LevelRef := fNode;
|
|
if (xsoWriteMultiRefObject in SerializationOptions) then begin
|
|
|
|
if Assigned(obj) then begin
|
|
id := IntToStr(fMaxRef);
|
|
Inc(fMaxRef);
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_href, '#'+id);
|
|
fNode := AddXMLChildNode(BodyNode, ns_Custom+':'+obj.ClassName);
|
|
AddXMLAttribute(fNode, tag_Id, id);
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', ns_Custom+':'+obj.ClassName);
|
|
end
|
|
else begin
|
|
refnode := AddXMLChildNode(fNode, lName);
|
|
AddXMLAttribute(refnode, tag_Nil, tag_NilValue);
|
|
end;
|
|
end
|
|
else begin
|
|
fNode := AddXMLChildNode(fNode, lName);
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', ns_Custom+':'+obj.ClassName);
|
|
end;
|
|
if Assigned(Obj) then Obj.WriteComplex(Self);
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.ReadArray(const aName: string; aClass: TClass;
|
|
var Ref; ArrayElementId: integer): Boolean;
|
|
var
|
|
obj : TROArray absolute Ref;
|
|
LevelRef: IXmlNode;
|
|
cnt : integer;
|
|
lNilAttr, hrefattr : IXMLNode;
|
|
id : string;
|
|
clsnme, namespc, clstype : string;
|
|
lActualClass : TROArrayClass;
|
|
begin
|
|
Result := False;
|
|
LevelRef := fNode;
|
|
try
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
fnode := GetObject(aName, ArrayElementId);
|
|
fnode := FindSoapReference(fnode);
|
|
if (fNode=NIL) then begin
|
|
// No such node found
|
|
Obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
lNilAttr := fNode.GetAttributeByName(tag_Nil);
|
|
if Assigned(lNilAttr) and (lNilAttr.Value = tag_NilValue) then begin
|
|
obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
hrefattr := fNode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
fNode := FindChildNodeByAttribute(BodyNode, tag_Id, id);
|
|
if fNode = nil then fNode := FindChildNodeByAttribute(fRespNode, tag_Id, id);
|
|
end;
|
|
|
|
clstype := VarToStr(fNode.GetAttributeValue('xsi:type', aClass.ClassName));
|
|
if (clstype = dts_Array) or (clstype = dts_Array2) then begin
|
|
//For arrays this attribute does't contain actual class name.
|
|
obj := TROArrayClass(aClass).Create;
|
|
end else begin
|
|
if xsoIgnoreStructureType in fSerializationOptions then begin
|
|
obj := TROArrayClass(aClass).Create;
|
|
end
|
|
else begin
|
|
SplitName(clstype, namespc, clsnme);
|
|
lActualClass := TROArrayClass(FindROClass(clsnme));
|
|
|
|
if not Assigned(lActualClass) then RaiseError(err_UnknownClassInStream,[clsnme]);
|
|
if not lActualClass.InheritsFrom(aClass) then RaiseError(err_UnexpectedClassInStream,[clsnme,aClass.ClassName]);
|
|
Obj := lActualClass.Create;
|
|
end;
|
|
end;
|
|
|
|
cnt := fNode.ChildrenCount;
|
|
Obj.Resize(cnt);
|
|
obj.ReadComplex(Self);
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.ReadStruct(const aName: string; aClass: TClass;
|
|
var Ref; ArrayElementId: integer): Boolean;
|
|
var
|
|
obj : TROComplexType absolute Ref;
|
|
LevelRef: IXmlNode;
|
|
lNilAttr, hrefattr : IXMLNode;
|
|
id : string;
|
|
clsnme, namespc, clstype : string;
|
|
lActualClass : TROComplexTypeClass;
|
|
begin
|
|
Result:=False;
|
|
LevelRef:=fNode;
|
|
try
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
fnode := GetObject(aName, ArrayElementId);
|
|
fnode := FindSoapReference(fnode);
|
|
if (fNode=NIL) then begin
|
|
// No such node found
|
|
obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
lNilAttr := fNode.GetAttributeByName(tag_Nil);
|
|
if Assigned(lNilAttr) and (lNilAttr.Value = tag_NilValue) then begin
|
|
obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
hrefattr := fNode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
fNode := FindChildNodeByAttribute(BodyNode, tag_Id, id);
|
|
if fNode = nil then
|
|
fNode := FindChildNodeByAttribute(fRespNode, tag_Id, id);
|
|
end;
|
|
|
|
clstype := VarToStr(fNode.GetAttributeValue('xsi:type', aClass.ClassName));
|
|
if (clstype = dts_Array) or (clstype = dts_Array2) then begin
|
|
//For arrays this attribute does't contain actual class name.
|
|
obj := TROComplexTypeClass(aClass).Create;
|
|
end else begin
|
|
if xsoIgnoreStructureType in fSerializationOptions then begin
|
|
obj := TROComplexTypeClass(aClass).Create;
|
|
end
|
|
else begin
|
|
SplitName(clstype, namespc, clsnme);
|
|
lActualClass := FindROClass(clsnme);
|
|
|
|
if not Assigned(lActualClass) then RaiseError(err_UnknownClassInStream,[clsnme]);
|
|
if not lActualClass.InheritsFrom(aClass) then RaiseError(err_UnexpectedClassInStream,[clsnme,aClass.ClassName]);
|
|
obj := lActualClass.Create;
|
|
end;
|
|
end;
|
|
Obj.ReadComplex(Self);
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
function TROXMLSerializer.FindNode(const aName: string;
|
|
ArrayElementId: integer): Boolean;
|
|
var
|
|
lNilAttr, hrefattr : IXMLNode;
|
|
id : string;
|
|
begin
|
|
Result:=False;
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
fnode := FindSoapReference(GetObject(aName, ArrayElementId));
|
|
|
|
if (fNode=NIL) then Result:=False; // No such node found
|
|
|
|
lNilAttr := fNode.GetAttributeByName(tag_Nil);
|
|
if Assigned(lNilAttr) and (lNilAttr.Value = tag_NilValue) then Exit;
|
|
|
|
Result := True;
|
|
hrefattr := fNode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
fNode := FindChildNodeByAttribute(BodyNode, tag_Id, id);
|
|
if fNode = nil then fNode := FindChildNodeByAttribute(fRespNode, tag_Id, id);
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.ReadException(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj: EROException absolute Ref;
|
|
LevelRef,
|
|
lNilAttr, hrefattr : IXMLNode;
|
|
id : string;
|
|
begin
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
|
|
LevelRef := fNode;
|
|
try
|
|
fnode := GetObject(aName, ArrayElementId);
|
|
|
|
fnode := FindSoapReference(fnode);
|
|
|
|
if (fNode=NIL) then begin
|
|
// No such node found
|
|
obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
lNilAttr := fNode.GetAttributeByName(tag_Nil);
|
|
if Assigned(lNilAttr) and (lNilAttr.Value = tag_NilValue) then begin
|
|
obj := NIL;
|
|
Exit;
|
|
end;
|
|
|
|
hrefattr := fNode.GetAttributeByName(tag_HRef);
|
|
if (hrefattr<>NIL) then begin
|
|
id := Copy(hrefattr.Value, 2, Length(hrefattr.Value)); // Removes the '#'
|
|
fNode := FindChildNodeByAttribute(BodyNode, tag_Id, id);
|
|
if fNode = nil then fNode := FindChildNodeByAttribute(fRespNode, tag_Id, id);
|
|
end;
|
|
Obj.ReadException(Self);
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXMLSerializer.WriteException(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj: EROException absolute Ref;
|
|
LevelRef,
|
|
xsiattr : IXMLNode;
|
|
begin
|
|
if fRespNode = nil then fRespNode := fNode;
|
|
LevelRef := fNode;
|
|
try
|
|
fNode := AddXMLChildNode(fNode, Unprefix(aName));
|
|
if not (xsoSendUntyped in SerializationOptions) then
|
|
xsiattr := AddXMLAttribute(fNode, 'xsi:type', ns_Custom+':'+obj.ClassName);
|
|
if Assigned(obj) then Obj.WriteException(Self);
|
|
finally
|
|
fNode := LevelRef;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$IFDEF DELPHI7UP}
|
|
GetLocaleFormatSettings(SOAPLocale,SOAPFormatSettings);
|
|
//ToDo: fix this for D6
|
|
{$ENDIF}
|
|
end.
|