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
1276 lines
42 KiB
ObjectPascal
1276 lines
42 KiB
ObjectPascal
unit uROXmlRpcMessage;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ 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, SysUtils, TypInfo, uROClasses, uROTypes, uROHttpTools,
|
|
uROSerializer, uROClient, uROClientIntf, uROXmlIntf, uRoRes, FMTBcd;
|
|
|
|
type
|
|
TROSimpleXmlWriter = class;
|
|
EROXmlRcpSerializerException = class(Exception);
|
|
TROXmlRpcType = (XRpcRequest, XRpcResponse, XRpcFaultResponse);
|
|
TROXmlRpcState = (XrsParam, XrsArray, Xrsstruct);
|
|
|
|
TROXmlRpcSerializer = class(TROSerializer)
|
|
private
|
|
fCurrState: TROXmlRpcState;
|
|
fDocument: IXMLDocument;
|
|
fStateCount: Integer;
|
|
fStates: array of TROXmlRpcState;
|
|
fType: TROXmlRpcType;
|
|
fMethodName: string;
|
|
fCurrentParamElement: IXMLNode;
|
|
fWriter: TROSimpleXmlWriter;
|
|
procedure PushState(aKind: TROXmlRpcState);
|
|
function PopState: TROXmlRpcState;
|
|
|
|
procedure BeginValue(aName: string);
|
|
procedure EndValue;
|
|
|
|
function StructGetMember(aRoot: IXMLNode; const aName: string; aRaiseException: Boolean): IXMLNode;
|
|
function GetValueNodecontentsForName(const aName: string): IXMLNode;
|
|
protected
|
|
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 WriteXml(const aName: String; const Ref; ArrayElementId: Integer = -1); override;
|
|
procedure WriteGuid(const aName: String; const Ref; ArrayElementId: Integer = -1); override;
|
|
procedure WriteDecimal(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); overload; 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 ReadXml(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 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); overload;override;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
procedure InitializeWrite(aType: TROXmlRpcType; aMethodName: string);
|
|
procedure InitializeRead(aStream: TStream);
|
|
|
|
property aType: TROXmlRpcType read fType write fType;
|
|
property aMethodName: string read fMethodName write fMethodName;
|
|
|
|
procedure WriteToStream(aStream: TStream);
|
|
|
|
procedure WriteException(aCode: Integer; aMsg: string);reintroduce;overload;
|
|
procedure ReadException(var aCode: Integer; var aMsg: string);reintroduce;overload;
|
|
end;
|
|
|
|
TROXmlRpcMessage = class(TROMessage)
|
|
protected
|
|
{ Internals }
|
|
function ReadException: Exception; override;
|
|
procedure WriteException(aStream: TStream; anException: Exception); override;
|
|
|
|
function CreateSerializer: TROSerializer; override;
|
|
|
|
{ IROMessage }
|
|
procedure Initialize(const aTransport: IROTransport; const anInterfaceName, aMessageName: string; aType: TMessageType); override;
|
|
|
|
|
|
procedure WriteToStream(aStream: TStream); override;
|
|
procedure ReadFromStream(aStream: TStream); override;
|
|
procedure InitializeExceptionMessage(const aTransport: IROTransport;
|
|
const aLibraryName: String; const anInterfaceName: String;
|
|
const aMessageName: String); override;
|
|
public
|
|
function IsValidMessage(aData: PChar; aLength: Integer): boolean; override;
|
|
end;
|
|
TROSimpleXmlWriter = class
|
|
private
|
|
fElementStack: TStrings;
|
|
fOutput: TMemoryStream;
|
|
fFinished: Boolean;
|
|
|
|
procedure WriteRawString(const s: string);
|
|
public
|
|
procedure WriteStartElement(const aElementName: string);
|
|
procedure WriteEndElement;
|
|
|
|
procedure WriteString(const aValue: WideString);
|
|
|
|
procedure SaveToStream(aDest: TStream);
|
|
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
|
|
property Finished: Boolean read fFinished;
|
|
end;
|
|
|
|
function StringToCurrInvariant(const aValue: string): Currency;
|
|
function CurrToStringInvariant(aValue: Currency): String;
|
|
|
|
implementation
|
|
uses
|
|
uROCompression, DateUtils, StrUtils, uROBinaryHelpers;
|
|
|
|
function FirstNonText(node: IXMLNode): IXMLNode;
|
|
begin
|
|
Result := Node;
|
|
while (Result <> nil) and (copy(Result.Name, 1, 1) = '#') do
|
|
Result := Result.NextSibling;
|
|
end;
|
|
|
|
function StringToCurrInvariant(const aValue: string): Currency;
|
|
var
|
|
s: string;
|
|
i: Integer;
|
|
Res: Int64;
|
|
begin
|
|
s := aValue;
|
|
i := Pos('.', s);
|
|
if i = 0 then begin
|
|
s := s + '.0000';
|
|
end
|
|
else begin
|
|
if Length(s) - i < 4 then
|
|
s := s + StringOfChar('0', 4 - (Length(s) - i))
|
|
else if Length(s) - i > 4 then
|
|
Delete(s, i + 5, MaxInt);
|
|
end;
|
|
Delete(s, i, 1);
|
|
Res := StrToInt64(s);
|
|
Move(Res, Result, 8);
|
|
end;
|
|
|
|
function CurrToStringInvariant(aValue: Currency): string;
|
|
var
|
|
Val: Int64;
|
|
begin
|
|
Move(aValue, Val, 8);
|
|
Result := IntToStr(Val); // we need it locale independent and without any thousand seperators
|
|
if Length(Result) <= 4 then
|
|
Result := StringOfChar('0', 5 - Length(Result)) + Result;
|
|
Insert('.', Result, Length(Result) - 3);
|
|
end;
|
|
|
|
{ TROXmlRpcMessage }
|
|
|
|
function TROXmlRpcMessage.CreateSerializer: TROSerializer;
|
|
begin
|
|
result := TROXmlRpcSerializer.Create;
|
|
end;
|
|
|
|
procedure TROXmlRpcMessage.Initialize(const aTransport: IROTransport;
|
|
const anInterfaceName, aMessageName: string; aType: TMessageType);
|
|
begin
|
|
inherited;
|
|
SetHTTPInfo(aTransport, DataFormatXml);
|
|
case aType of
|
|
mtRequest: TROXmlRpcSerializer(Serializer).InitializeWrite(XRpcRequest, anInterfaceName + '.' + aMessageName);
|
|
mtResponse: TROXmlRpcSerializer(Serializer).InitializeWrite(XRpcResponse, anInterfaceName + '.' + aMessageName);
|
|
mtException: TROXmlRpcSerializer(Serializer).InitializeWrite(XRpcFaultResponse, anInterfaceName + '.' + aMessageName)
|
|
else
|
|
raise EROXmlRcpSerializerException.Create('Unsupported request type');
|
|
end
|
|
end;
|
|
|
|
procedure TROXmlRpcMessage.InitializeExceptionMessage(
|
|
const aTransport: IROTransport; const aLibraryName, anInterfaceName,
|
|
aMessageName: String);
|
|
begin
|
|
inherited;
|
|
SetHTTPInfo(aTransport, DataFormatXml);
|
|
end;
|
|
|
|
function TROXmlRpcMessage.IsValidMessage(aData: PChar;
|
|
aLength: Integer): boolean;
|
|
var
|
|
str: string;
|
|
begin
|
|
SetString(str, aData, aLength);
|
|
Result :=
|
|
(Pos('<methodRequest>', str) > 0) or
|
|
(Pos('<methodCall>', str) > 0) or
|
|
(Pos('<methodResponse>', str) > 0);
|
|
end;
|
|
|
|
function TROXmlRpcMessage.ReadException: Exception;
|
|
var
|
|
lCode: Integer;
|
|
lMsg: string;
|
|
cl: string;
|
|
idx: Integer;
|
|
begin
|
|
TROXmlRpcSerializer(Serializer).ReadException(lCode, lMsg);
|
|
case lCode of
|
|
-32700, -32701, -32702, -32600, -32603, -32300:
|
|
begin
|
|
Result := EROXmlRcpSerializerException.Create(lMsg);
|
|
exit;
|
|
end;
|
|
end;
|
|
idx := Pos(': ', lMsg);
|
|
if (idx = 0) or (idx > Pos(' ', lMsg)) then begin
|
|
result := Exception.Create(lMsg);
|
|
exit;
|
|
end;
|
|
cl := Copy(lMsg, 1, Idx -1);
|
|
Delete(lMsg, 1, Idx + 1);
|
|
|
|
result := CreateException(cl, lMsg);
|
|
|
|
// Reads the other fields which have been properly serialized
|
|
//if result.InheritsFrom(EROException) then
|
|
//EROException(Result).Read(Serializer);
|
|
end;
|
|
|
|
procedure TROXmlRpcMessage.ReadFromStream(aStream: TStream);
|
|
var
|
|
s: string;
|
|
encryptedheader: array[0..5] of char;
|
|
begin
|
|
inherited;
|
|
aStream.Position := 0;
|
|
|
|
try
|
|
TROXmlRpcSerializer(Serializer).InitializeRead(aStream);
|
|
except
|
|
aStream.Position := 0;
|
|
aStream.Read(encryptedheader, 6);
|
|
if (encryptedheader[0] = 'r') and (encryptedheader[1] = 'o') and
|
|
(encryptedheader[2] = 'r') and (encryptedheader[3] = 'o') and
|
|
(encryptedheader[4] = 'c') and (encryptedheader[5] = 'k') then
|
|
RaiseInvalidStreamError(err_InvalidHeaderEncrypted, [], aStream);
|
|
raise;
|
|
end;
|
|
if TROXmlRpcSerializer(Serializer).aType = XRpcFaultResponse then
|
|
ProcessException
|
|
else begin
|
|
s := TROXmlRpcSerializer(Serializer).aMethodName;
|
|
if pos('.', s) = 0 then
|
|
MessageName := s
|
|
else begin
|
|
MessageName := copy(s, pos('.', s) + 1, MaxInt);
|
|
InterfaceName := copy(s, 1, pos('.', s) - 1);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcMessage.WriteException(aStream: TStream;
|
|
anException: Exception);
|
|
begin
|
|
inherited;
|
|
TROXmlRpcSerializer(Serializer).InitializeWrite(XRpcFaultResponse, '');
|
|
if anException is EROXmlRcpSerializerException then
|
|
TROXmlRpcSerializer(Serializer).WriteException(-32600, anException.Message)
|
|
else
|
|
TROXmlRpcSerializer(Serializer).WriteException(1, anException.ClassName+': '+anException.Message);
|
|
// if anException is EROException then EROException(anException).Write(Serializer);
|
|
TROXmlRpcSerializer(Serializer).WriteToStream(aStream);
|
|
end;
|
|
|
|
procedure TROXmlRpcMessage.WriteToStream(aStream: TStream);
|
|
begin
|
|
TROXmlRpcSerializer(Serializer).WriteToStream(aStream);
|
|
inherited;
|
|
end;
|
|
|
|
{ TROXmlRpcSerializer }
|
|
|
|
constructor TROXmlRpcSerializer.Create;
|
|
begin
|
|
inherited Create;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.InitializeWrite(aType: TROXmlRpcType; aMethodName: string);
|
|
begin
|
|
ftype := aType;
|
|
fMethodName := aMethodName;
|
|
if fWriter <> nil then fWriter.Free;
|
|
fWriter := TROSimpleXmlWriter.Create;
|
|
case aType of
|
|
XRpcFaultResponse:
|
|
begin
|
|
fWriter.WriteStartElement('methodResponse');
|
|
fWriter.WriteStartElement('fault');
|
|
fCurrState := XrsArray;
|
|
end;
|
|
XRpcResponse:
|
|
begin
|
|
fWriter.WriteStartElement('methodResponse');
|
|
fWriter.WriteStartElement('params');
|
|
end;
|
|
XRpcRequest:
|
|
begin
|
|
fWriter.WriteStartElement('methodCall');
|
|
fWriter.WriteStartElement('methodName');
|
|
fWriter.WriteString(fMethodName);
|
|
fWriter.WriteEndElement();
|
|
fWriter.WriteStartElement('params');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.CustomWriteObject(const aName: string;
|
|
aClass: TClass; const Ref; ArrayElementId: integer);
|
|
var
|
|
anObject: TObject absolute Ref;
|
|
lTemp: Binary;
|
|
begin
|
|
if anObject is TStream then begin
|
|
lTemp := Binary.Create;
|
|
try
|
|
TStream(anObject).Seek(0, soFromBeginning);
|
|
EncodeStream(TStream(anObject), lTemp);
|
|
fWriter.WriteString(lTemp.ToString);
|
|
finally
|
|
lTemp.Free;
|
|
end;
|
|
end else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.BeginWriteObject(const aName: string;
|
|
aClass: TClass; anObject: TObject; var LevelRef: IInterface;
|
|
var IsValidType: boolean; out IsAssigned: Boolean;
|
|
ArrayElementId: integer);
|
|
begin
|
|
if aClass <> nil then
|
|
inherited;
|
|
|
|
if not assigned(anObject) then raise EROXmlRcpSerializerException.Create('Nil objects not supported by xmlrpc');
|
|
|
|
IsAssigned := True;
|
|
|
|
BeginValue(aName);
|
|
|
|
if anObject is TStream then begin
|
|
fWriter.WriteStartElement('base64');
|
|
// write binary
|
|
IsValidType := true; // Adds streams/binaries as supported type
|
|
end else if anObject is TROArray then begin
|
|
fWriter.WriteStartElement('array');
|
|
PushState(XrsArray);
|
|
fWriter.WriteStartElement('data');
|
|
IsValidType := true; // Adds Array as supported type
|
|
end
|
|
else if anObject is TROComplexType then begin
|
|
fWriter.WriteStartElement('struct');
|
|
PushState(Xrsstruct);
|
|
IsValidType := true;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.EndWriteObject(const aName: string;
|
|
aClass: TClass; anObject: TObject; const LevelRef: IInterface);
|
|
begin
|
|
if anObject is TStream then begin
|
|
fWriter.WriteEndElement;
|
|
end else if anObject is TROArray then begin
|
|
fWriter.WriteEndElement;
|
|
fWriter.WriteEndElement;
|
|
if PopState <> xrsArray then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
end
|
|
else if anObject is TROComplexType then begin
|
|
if PopState <> Xrsstruct then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
fWriter.WriteEndElement;
|
|
end;
|
|
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteDateTime(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('dateTime.iso8601');
|
|
fWriter.WriteString(FormatDateTime('yyyymmdd"T"hh:nn:ss', DateTime(Ref)));
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteEnumerated(const aName: string;
|
|
anEnumTypeInfo: PTypeInfo; const Ref; ArrayElementId: integer);
|
|
begin
|
|
BeginValue(aName);
|
|
if anEnumTypeInfo.Name = 'Boolean' then
|
|
begin
|
|
fWriter.WriteStartElement('boolean');
|
|
if boolean(Ref) then
|
|
fWriter.WriteString('1')
|
|
else
|
|
fWriter.WriteString('0');
|
|
fWriter.WriteEndElement;
|
|
end else
|
|
begin
|
|
fWriter.WriteStartElement('string');
|
|
fWriter.WriteString(GetEnumName(anEnumTypeInfo, Ord(byte(Ref))));
|
|
fWriter.WriteEndElement;
|
|
end;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteDouble(const aName: string;
|
|
aFloatType: TFloatType; const Ref; ArrayElementId: integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
// Str doesn't use the locale settings
|
|
case aFloatType of
|
|
ftSingle: s := FloatToStr(Single(Ref));
|
|
ftDouble: s := FloatToStr(Double(Ref));
|
|
ftExtended: s := FloatToStr(Extended(Ref));
|
|
ftComp: s := FloatToStr(Comp(Ref));
|
|
ftCurr:
|
|
begin
|
|
s :=CurrToStringInvariant(currency(Ref));
|
|
WriteUTF8String(aName, s);
|
|
exit;
|
|
end;
|
|
end;
|
|
s := StringReplace(s, DecimalSeparator, '.', []);
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('double');
|
|
fWriter.WriteString(s);
|
|
fWriter.WriteEndElement();
|
|
EndValue();
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteInt64(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('string'); // no way around
|
|
fWriter.WriteString(IntToStr(Int64(ref)));
|
|
fWriter.WriteEndElement();
|
|
EndValue();
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteInteger(const aName: string;
|
|
anOrdType: TOrdType; const Ref; ArrayElementId: integer);
|
|
var
|
|
aIntVal: Integer;
|
|
begin
|
|
case anOrdType of
|
|
otSByte: aIntVal := ShortInt(Ref);
|
|
otUByte: aIntVal := Byte(Ref);
|
|
otSWord: aIntVal := SmallInt(Ref);
|
|
otUWord: aIntVal := Word(Ref);
|
|
otSLong: aIntVal := Integer(Ref);
|
|
otULong: aIntVal := Cardinal(Ref);
|
|
else
|
|
aIntVal := 0;
|
|
end;
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('i4');
|
|
fWriter.WriteString(IntToStr(aIntVal));
|
|
fWriter.WriteEndElement();
|
|
EndValue();
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteUTF8String(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('string');
|
|
fWriter.WriteString(string(Ref));
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteToStream(aStream: TStream);
|
|
begin
|
|
if not fWriter.Finished then
|
|
begin
|
|
fWriter.WriteEndElement(); // params/fault
|
|
fWriter.WriteEndElement(); // methodRequest/methodRespones
|
|
end;
|
|
fWriter.SaveToStream(aStream);
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteVariant(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
raise EROXmlRcpSerializerException.Create('Variants not supported by xmlrpc');
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteWideString(const aName: string;
|
|
const Ref; ArrayElementId: integer);
|
|
begin
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('string');
|
|
fWriter.WriteString(WideString(Ref));
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteException(aCode: Integer; aMsg: string);
|
|
begin
|
|
BeginValue('');
|
|
fWriter.WriteStartElement('struct');
|
|
PushState(Xrsstruct);
|
|
WriteInteger('faultCode', otSLong, aCode);
|
|
WriteUTF8String('faultString', aMsg);
|
|
if PopState <> Xrsstruct then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.InitializeRead(aStream: TStream);
|
|
var
|
|
el, tmp: IXMLNode;
|
|
begin
|
|
fDocument := NewROXmlDocument;
|
|
fDocument.New;
|
|
fDocument.LoadFromStream(aStream);
|
|
if (fDocument.DocumentNode.Name = 'methodRequest') or (fDocument.DocumentNode.Name = 'methodCall') then
|
|
fType := XRpcRequest
|
|
else if fDocument.DocumentNode.Name = 'methodResponse' then
|
|
fType := XRpcResponse
|
|
else
|
|
raise EROXmlRcpSerializerException.Create('Invalid xmlrpc document');
|
|
|
|
el := fDocument.DocumentNode;
|
|
if fType = xrpcRequest then begin
|
|
tmp := el.GetNodeByName('methodName');
|
|
if tmp = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc document');
|
|
fMethodName := tmp.Value;
|
|
tmp := el.GetNodeByName('params');
|
|
if tmp = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc document');
|
|
fCurrentParamElement := FirstNonText(tmp.FirstChild);
|
|
end else begin
|
|
tmp := el.GetNodeByName('fault');
|
|
if tmp = nil then begin
|
|
tmp := el.GetNodeByName('params');
|
|
if tmp = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc document');
|
|
tmp := FirstNonText(tmp.FirstChild);
|
|
end
|
|
else
|
|
fType := XRpcFaultResponse;
|
|
fCurrentParamElement := tmp;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TROXmlRpcSerializer.StructGetMember(aRoot: IXMLNode; const aName: string; aRaiseException: Boolean): IXMLNode;
|
|
var
|
|
i: Integer;
|
|
tmp: IXMLNode;
|
|
begin
|
|
for i := 0 to aRoot.ChildrenCount -1 do
|
|
begin
|
|
Result := aRoot.Children[i];
|
|
tmp := Result.GetNodeByName('name');
|
|
if (tmp <> nil) and (tmp.Value = aName) then begin
|
|
Result := result.GetNodeByName('value');
|
|
if (Result = nil) and aRaiseException then EROXmlRcpSerializerException.Create('Unknown node: '+aName);
|
|
exit;
|
|
end;
|
|
end;
|
|
if (Result = nil) and aRaiseException then EROXmlRcpSerializerException.Create('Unknown node: '+aName);
|
|
result := nil;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadException(var aCode: Integer; var aMsg: string);
|
|
var
|
|
tmp, val: IXMLNode;
|
|
begin
|
|
tmp := fCurrentParamElement.GetNodeByName('value');
|
|
if tmp = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc exception');
|
|
tmp := tmp.GetNodeByName('struct');
|
|
if tmp = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc exception');
|
|
|
|
val := StructGetMember(tmp, 'faultCode', true);
|
|
val := val.GetNodeByName('i4');
|
|
if val = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc exception');
|
|
acode := val.Value;
|
|
|
|
val := StructGetMember(tmp, 'faultString', true);
|
|
val := val.GetNodeByName('string');
|
|
if val = nil then raise EROXmlRcpSerializerException.Create('Invalid xmlrpc exception');
|
|
aMsg := val.Value;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.BeginReadObject(const aName: string;
|
|
aClass: TClass; var anObject: TObject; var LevelRef: IInterface;
|
|
var IsValidType: boolean; ArrayElementId: integer);
|
|
var
|
|
el: IXMLNode;
|
|
begin
|
|
if aClass.InheritsFrom(TStream) then begin
|
|
anObject := TROBinaryMemoryStream.Create;
|
|
IsValidType := true;
|
|
end
|
|
else if aclass.InheritsFrom(TROArray) then begin
|
|
anObject := TROComplexTypeClass(aClass).Create;
|
|
IsValidType := true;
|
|
end
|
|
else if aclass.InheritsFrom(TROComplexType) then begin
|
|
anObject := TROComplexTypeClass(aClass).Create;
|
|
el :=GetValueNodeContentsForName(aName);
|
|
if (el = nil) or (el.Name <> 'struct') then raise EROXmlRcpSerializerException.Create('Not a struct');
|
|
PushState(Xrsstruct);
|
|
fCurrentParamElement := el;
|
|
IsValidType := true;
|
|
end else
|
|
IsValidType := false;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.CustomReadObject(const aName: string;
|
|
aClass: TClass; var Ref; ArrayElementId: integer);
|
|
var
|
|
obj: TObject absolute ref;
|
|
el,
|
|
tmp: IXMLNode;
|
|
ci: Integer;
|
|
itemref: Pointer;
|
|
tmpstream: Binary;
|
|
begin
|
|
if obj is TROArray then begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'array' then raise EROXmlRcpSerializerException.Create('Not at array');
|
|
el := FirstNonText(el.FirstChild);
|
|
if el.Name <> 'data' then raise EROXmlRcpSerializerException.Create('Not an array');
|
|
tmp := fCurrentParamElement;
|
|
fCurrentParamElement := FirstNonText(el.FirstChild);
|
|
PushState(XrsArray);
|
|
ci := 0;
|
|
TROArray(obj).Resize(el.ChildrenCount); // might differ if there are junk entries
|
|
while fCurrentParamElement <> nil do begin
|
|
if TROArray(obj).GetItemClass <> nil then begin
|
|
itemref := nil;
|
|
Read(RO_ArrayItemName, TROArray(obj).GetItemType, itemref, ci);
|
|
TROArray(obj).SetItemRef(ci, itemref);
|
|
end else begin
|
|
itemref := TROArray(obj).GetItemRef(ci);
|
|
Read(RO_ArrayItemName, TROArray(obj).GetItemType, itemref^, ci);
|
|
end;
|
|
inc(ci);
|
|
end;
|
|
if ci <> el.ChildrenCount then TROArray(obj).Resize(ci);
|
|
if PopState <> XrsArray then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
fCurrentParamElement := tmp;
|
|
end else if obj is TStream then begin
|
|
el := GetValueNodecontentsForName(aName);
|
|
if el.Name <> 'base64' then raise EROXmlRcpSerializerException.Create('Not a base64 block');
|
|
tmpstream := TROBinaryMemoryStream.Create(el.Value);
|
|
try
|
|
DecodeStream(tmpstream, TStream(obj));
|
|
TStream(obj).Position := 0;
|
|
finally
|
|
tmpstream.Free;
|
|
end;
|
|
end else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.EndReadObject(const aName: string;
|
|
aClass: TClass; var anObject: TObject; const LevelRef: IInterface);
|
|
var
|
|
el: IXMLNode;
|
|
begin
|
|
if aclass.InheritsFrom(TROComplexType) and not (aClass.InheritsFrom(TStream) or aclass.InheritsFrom(TROArray)) then begin
|
|
el := fCurrentParamElement;
|
|
if (el = nil) or (el.Name <> 'struct') or (PopState() <> Xrsstruct)then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
case fCurrState of
|
|
XrsArray:
|
|
el := el.Parent;
|
|
XrsParam:
|
|
el := el.Parent.Parent;
|
|
Xrsstruct:
|
|
el := el.Parent.Parent.Parent;
|
|
end;
|
|
fCurrentParamElement := FirstNonText(el.NextSibling);
|
|
end
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadDateTime(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
el: IXMLNode;
|
|
s: string;
|
|
h,m,sec: Integer;
|
|
begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'dateTime.iso8601' then raise EROXmlRcpSerializerException.Create('Not a datetime');
|
|
s := el.Value;
|
|
if (Length(s) <> 17) or (s[9] <> 'T') then raise EROXmlRcpSerializerException.Create('Invalid date format');
|
|
DateTime(ref) := EncodeDate(
|
|
StrToInt(copy(s,1,4)), //yyyy
|
|
StrToInt(copy(s,5,2)), //mm
|
|
StrToInt(copy(s,7,2))); //dd
|
|
// skip the T
|
|
delete(s,1,9);
|
|
h := StrToInt(copy(s,1,2)); //hh
|
|
delete(s,1,2);
|
|
if copy(s,1,1) = ':' then delete(s,1,1);
|
|
m := StrToInt(copy(s,1,2)); //nn
|
|
delete(s,1,2);
|
|
if copy(s,1,1) = ':' then delete(s,1,1);
|
|
sec := StrToInt(copy(s,1,2)); //ss
|
|
DateTime(ref) := DateTime(ref) + EncodeTime(H, M, Sec, 0)
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadEnumerated(const aName: string;
|
|
anEnumTypeInfo: PTypeInfo; var Ref; ArrayElementId: integer);
|
|
var
|
|
enumval: Integer;
|
|
s: string;
|
|
el: IXMLNode;
|
|
begin
|
|
if anEnumTypeInfo.Name = 'Boolean' then begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'boolean' then raise EROXmlRcpSerializerException.Create('Not a boolean');
|
|
if (el.Value = '1') or (el.Value = 'true') then
|
|
enumval := 1
|
|
else
|
|
enumval := 0;
|
|
end else begin
|
|
ReadUTF8String(aName, s);
|
|
enumval := GetEnumValue(anEnumTypeInfo, s);
|
|
if enumval < 0 then
|
|
raise EROXmlRcpSerializerException.Create('Unknown value "'+ s +'" for enum "'+anEnumTypeInfo^.Name+'"');
|
|
end;
|
|
byte(Ref) := enumval;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadDouble(const aName: string;
|
|
aFloatType: TFloatType; var Ref; ArrayElementId: integer);
|
|
var
|
|
d: Double;
|
|
el: IXMLNode;
|
|
c: Integer;
|
|
s: string;
|
|
begin
|
|
if aFloatType = ftCurr then
|
|
begin
|
|
ReadUTF8String(aName, s);
|
|
Currency(Ref) := StringToCurrInvariant(s);
|
|
exit;
|
|
end;
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'double' then raise EROXmlRcpSerializerException.Create('Not a double');
|
|
|
|
Val(el.Value, d, c);
|
|
if c <> 0 then raise EROXmlRcpSerializerException.Create('Invalid float format');
|
|
|
|
case aFloatType of
|
|
ftSingle: Single(Ref) := d;
|
|
ftDouble: Double(Ref) := d;
|
|
ftExtended: Extended(Ref) := d;
|
|
ftComp: Comp(Ref) := d;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadInt64(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
s: string;
|
|
begin
|
|
ReadUTF8String(aName, s);
|
|
Int64(Ref) := StrToInt64(s);
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadInteger(const aName: string;
|
|
anOrdType: TOrdType; var Ref; ArrayElementId: integer);
|
|
var
|
|
el: IXMLNode;
|
|
aVal: Integer;
|
|
begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if (el.Name <> 'i4') and (el.Name <> 'int') then raise EROXmlRcpSerializerException.Create('Not an integer');
|
|
aVal := StrToInt(el.Value);
|
|
case anOrdType of
|
|
otSByte: ShortInt(Ref) := aVal;
|
|
otUByte: Byte(Ref) := aVal;
|
|
otSWord: SmallInt(Ref) := aVal;
|
|
otUWord: Word(Ref) := aVal;
|
|
otSLong: Longint(Ref) := aVal;
|
|
otULong: Cardinal(Ref) := aVal;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadUTF8String(const aName: string; var Ref;
|
|
ArrayElementId, iMaxLength: integer);
|
|
var
|
|
el: IXMLNode;
|
|
begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'string' then raise EROXmlRcpSerializerException.Create('Not a string');
|
|
string(Ref) := el.Value;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadVariant(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
raise EROXmlRcpSerializerException.Create('Variants not supported by xmlrpc');
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadWideString(const aName: string; var Ref;
|
|
ArrayElementId, iMaxLength: integer);
|
|
var
|
|
el: IXMLNode;
|
|
begin
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'string' then raise EROXmlRcpSerializerException.Create('Not a string');
|
|
WideString(Ref) := el.Value;
|
|
end;
|
|
|
|
|
|
destructor TROXmlRpcSerializer.Destroy;
|
|
begin
|
|
fWriter.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROXmlRpcSerializer.PopState: TROXmlRpcState;
|
|
begin
|
|
if fStateCount = 0 then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
Dec(fStateCount);
|
|
Result := fCurrState;
|
|
fCurrState := fStates[fStatecount];
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.PushState(aKind: TROXmlRpcState);
|
|
begin
|
|
if fStateCount = Length(fStates) then
|
|
SetLength(fStates, Length(FStates) + 4);
|
|
fStates[fStateCount] := fCurrState;
|
|
Inc(FStateCount);
|
|
fCurrState := aKind;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.BeginValue(aName: string);
|
|
begin
|
|
case fCurrState of
|
|
XrsParam: fWriter.WriteStartElement('param');
|
|
Xrsstruct:
|
|
begin
|
|
fWriter.WriteStartElement('member');
|
|
fWriter.WriteStartElement('name');
|
|
fWriter.WriteString(aName);
|
|
fWriter.WriteEndElement;
|
|
end;
|
|
end;
|
|
fWriter.WriteStartElement('value');
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.EndValue;
|
|
begin
|
|
fWriter.WriteEndElement;
|
|
case fCurrState of
|
|
XrsParam,
|
|
Xrsstruct:
|
|
fWriter.WriteEndElement;
|
|
end;
|
|
end;
|
|
|
|
function TROXmlRpcSerializer.GetValueNodecontentsForName(
|
|
const aName: string): IXMLNode;
|
|
begin
|
|
if fCurrentParamElement = nil then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
case fCurrState of
|
|
XrsArray:
|
|
begin
|
|
Result := FirstNonText(fCurrentParamElement.FirstChild);
|
|
fCurrentParamElement := FirstNonText(fCurrentParamElement.NextSibling);
|
|
end;
|
|
XrsParam:
|
|
begin
|
|
Result := FirstNonText(fCurrentParamElement.FirstChild);
|
|
if result = nil then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
if result.Name = 'value' then Result := FirstNonText(Result.FirstChild);
|
|
fCurrentParamElement := FirstNonText(fCurrentParamElement.NextSibling);
|
|
end;
|
|
Xrsstruct:
|
|
begin
|
|
Result := fCurrentParamElement;
|
|
if result = nil then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
Result := StructGetMember(Result, aName, True);
|
|
Result := FirstNonText(Result.FirstChild);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadXml(const aName: String; var Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: WideString;
|
|
res: IXMLDocument;
|
|
begin
|
|
ReadWideString(aName, s, ArrayElementID);
|
|
if s = '' then
|
|
IXmlNode(Ref) := nil
|
|
else begin
|
|
res := NewROXmlDocument;
|
|
Res.New;
|
|
Res.XML := s;
|
|
IXmlNode(Ref) := res.DocumentNode;
|
|
end;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteXml(const aName: String; const Ref;
|
|
ArrayElementId: Integer);
|
|
var
|
|
s: WideString;
|
|
begin
|
|
if IXMLNode(Ref) = nil then
|
|
S := ''
|
|
else
|
|
s := IXMLNode(Ref).XML;
|
|
WriteWideString(aName, s, ArrayElementId);
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.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 TROXmlRpcSerializer.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 TROXmlRpcSerializer.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 TROXmlRpcSerializer.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 TROXmlRpcSerializer.ReadBinary(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj: Binary absolute ref;
|
|
el: IXMLNode;
|
|
tmpstream: Binary;
|
|
begin
|
|
el := GetValueNodecontentsForName(aName);
|
|
if el.Name <> 'base64' then raise EROXmlRcpSerializerException.Create('Not a base64 block');
|
|
Obj := TROBinaryMemoryStream.Create;
|
|
tmpstream := TROBinaryMemoryStream.Create(el.Value);
|
|
try
|
|
DecodeStream(tmpstream, obj);
|
|
obj.Position := 0;
|
|
finally
|
|
tmpstream.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TROXmlRpcSerializer.WriteBinary(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj: Binary absolute Ref;
|
|
lTemp: Binary;
|
|
begin
|
|
if not assigned(obj) then raise EROXmlRcpSerializerException.Create('Nil objects not supported by xmlrpc');
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('base64');
|
|
// write binary
|
|
lTemp := Binary.Create;
|
|
try
|
|
obj.Seek(0, soFromBeginning);
|
|
EncodeStream(obj, lTemp);
|
|
fWriter.WriteString(lTemp.ToString);
|
|
finally
|
|
lTemp.Free;
|
|
end;
|
|
// endwriteobject
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
|
|
function TROXmlRpcSerializer.ReadArray(const aName: string; aClass: TClass;
|
|
var Ref; ArrayElementId: integer): Boolean;
|
|
var
|
|
obj : TROArray absolute Ref;
|
|
el,
|
|
tmp: IXMLNode;
|
|
// ci: Integer;
|
|
// itemref: Pointer;
|
|
begin
|
|
Result:=True;
|
|
obj := TROArrayClass(aClass).Create;
|
|
el := GetValueNodeContentsForName(aName);
|
|
if el.Name <> 'array' then raise EROXmlRcpSerializerException.Create('Not at array');
|
|
el := FirstNonText(el.FirstChild);
|
|
if el.Name <> 'data' then raise EROXmlRcpSerializerException.Create('Not an array');
|
|
tmp := fCurrentParamElement;
|
|
fCurrentParamElement := FirstNonText(el.FirstChild);
|
|
PushState(XrsArray);
|
|
|
|
obj.Resize(el.ChildrenCount); // might differ if there are junk entries
|
|
(*
|
|
ci := 0;
|
|
while fCurrentParamElement <> nil do begin
|
|
if obj.GetItemClass <> nil then begin
|
|
itemref := nil;
|
|
Read(RO_ArrayItemName, obj.GetItemType, itemref, ci);
|
|
obj.SetItemRef(ci, itemref);
|
|
end else begin
|
|
itemref := obj.GetItemRef(ci);
|
|
Read(RO_ArrayItemName, obj.GetItemType, itemref^, ci);
|
|
end;
|
|
inc(ci);
|
|
end;
|
|
if ci <> el.ChildrenCount then obj.Resize(ci);
|
|
*)
|
|
obj.ReadComplex(Self);
|
|
if PopState <> XrsArray then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
fCurrentParamElement := tmp;
|
|
end;
|
|
|
|
function TROXmlRpcSerializer.ReadStruct(const aName: string;
|
|
aClass: TClass; var Ref; ArrayElementId: integer): Boolean;
|
|
var
|
|
obj : TROComplexType absolute Ref;
|
|
el: IXMLNode;
|
|
begin
|
|
Result:=True;
|
|
obj := TROComplexTypeClass(aClass).Create;
|
|
el :=GetValueNodeContentsForName(aName);
|
|
if (el = nil) or (el.Name <> 'struct') then raise EROXmlRcpSerializerException.Create('Not a struct');
|
|
PushState(Xrsstruct);
|
|
fCurrentParamElement := el;
|
|
Obj.ReadComplex(Self);
|
|
el := fCurrentParamElement;
|
|
if (el = nil) or (el.Name <> 'struct') or (PopState() <> Xrsstruct)then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
case fCurrState of
|
|
XrsArray:
|
|
el := el.Parent;
|
|
XrsParam:
|
|
el := el.Parent.Parent;
|
|
Xrsstruct:
|
|
el := el.Parent.Parent.Parent;
|
|
end;
|
|
fCurrentParamElement := FirstNonText(el.NextSibling);
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteArray(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : TROArray absolute Ref;
|
|
begin
|
|
if not assigned(obj) then raise EROXmlRcpSerializerException.Create('Nil objects not supported by xmlrpc');
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('array');
|
|
PushState(XrsArray);
|
|
fWriter.WriteStartElement('data');
|
|
obj.WriteComplex(Self);
|
|
fWriter.WriteEndElement;
|
|
fWriter.WriteEndElement;
|
|
if PopState <> xrsArray then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteStruct(const aName: string; const Ref;
|
|
ArrayElementId: integer);
|
|
var
|
|
obj : TROComplexType absolute Ref;
|
|
begin
|
|
if not assigned(obj) then raise EROXmlRcpSerializerException.Create('Nil objects not supported by xmlrpc');
|
|
BeginValue(aName);
|
|
fWriter.WriteStartElement('struct');
|
|
PushState(Xrsstruct);
|
|
obj.WriteComplex(Self);
|
|
if PopState <> Xrsstruct then raise EROXmlRcpSerializerException.Create('Invalid state');
|
|
fWriter.WriteEndElement;
|
|
EndValue;
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.ReadException(const aName: string; var Ref;
|
|
ArrayElementId: integer);
|
|
begin
|
|
// not used
|
|
end;
|
|
|
|
procedure TROXmlRpcSerializer.WriteException(const aName: string;
|
|
const Ref; ArrayElementId: integer);
|
|
begin
|
|
// not used
|
|
end;
|
|
|
|
{ TROSimpleXmlWriter }
|
|
|
|
constructor TROSimpleXmlWriter.Create;
|
|
begin
|
|
inherited Create;
|
|
fElementStack := TStringList.Create;
|
|
fOutput := TMemoryStream.Create;
|
|
end;
|
|
|
|
destructor TROSimpleXmlWriter.Destroy;
|
|
begin
|
|
fOutput.Free;
|
|
fElementStack.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROSimpleXmlWriter.SaveToStream(aDest: TStream);
|
|
begin
|
|
if not fFinished then raise EROXmlRcpSerializerException.Create('XmlDocument not finished yet');
|
|
fOutput.Position := 0;
|
|
fOutput.SaveToStream(aDest);
|
|
end;
|
|
|
|
procedure TROSimpleXmlWriter.WriteEndElement;
|
|
begin
|
|
if fFinished then raise EROXmlRcpSerializerException.Create('XmlDocument already finished');
|
|
if fElementStack.Count = 0 then raise EROXmlRcpSerializerException.Create('Root element missing');
|
|
WriteRawString('</' + fElementStack[fElementStack.Count -1] + '>');
|
|
fElementStack.Delete(fElementStack.Count -1);
|
|
if fElementStack.Count = 0 then fFinished := true;
|
|
end;
|
|
|
|
procedure TROSimpleXmlWriter.WriteRawString(const s: string);
|
|
begin
|
|
if s <> '' then
|
|
fOutput.Write(s[1], Length(s));
|
|
end;
|
|
|
|
procedure TROSimpleXmlWriter.WriteStartElement(const aElementName: string);
|
|
begin
|
|
if fFinished then raise EROXmlRcpSerializerException.Create('XmlDocument already finished');
|
|
fElementStack.Add(aElementName);
|
|
WriteRawString('<' + aElementName + '>');
|
|
end;
|
|
|
|
procedure TROSimpleXmlWriter.WriteString(const aValue: WideString);
|
|
var
|
|
lInputValue: UTF8String;
|
|
lCurrPos, i: Integer;
|
|
lRealString: UTF8String;
|
|
begin
|
|
if fFinished then raise EROXmlRcpSerializerException.Create('XmlDocument already finished');
|
|
if fElementStack.Count = 0 then raise EROXmlRcpSerializerException.Create('Root element missing');
|
|
lInputValue := UTF8Encode(aValue);
|
|
SetLength(lRealString, Length(lInputValue) + 16);
|
|
lCurrPos := 0;
|
|
for i := 1 to length(lInputValue) do
|
|
begin
|
|
case lInputValue[i] of
|
|
'<':
|
|
begin
|
|
if lCurrPos + 4 > Length(lRealString) then
|
|
SetLength(lRealString, lCurrPos + 16 + 4);
|
|
lRealString[lCurrPos + 1] := '&';
|
|
lRealString[lCurrPos + 2] := 'l';
|
|
lRealString[lCurrPos + 3] := 't';
|
|
lRealString[lCurrPos + 4] := ';';
|
|
inc(lCurrPos, 4);
|
|
end;
|
|
'>':
|
|
begin
|
|
if lCurrPos + 4 > Length(lRealString) then
|
|
SetLength(lRealString, lCurrPos + 16 + 4);
|
|
lRealString[lCurrPos + 1] := '&';
|
|
lRealString[lCurrPos + 2] := 'g';
|
|
lRealString[lCurrPos + 3] := 't';
|
|
lRealString[lCurrPos + 4] := ';';
|
|
inc(lCurrPos, 4);
|
|
end;
|
|
'&':
|
|
begin
|
|
if lCurrPos + 5 > Length(lRealString) then
|
|
SetLength(lRealString, lCurrPos + 16 + 5);
|
|
lRealString[lCurrPos + 1] := '&';
|
|
lRealString[lCurrPos + 2] := 'a';
|
|
lRealString[lCurrPos + 3] := 'm';
|
|
lRealString[lCurrPos + 4] := 'p';
|
|
lRealString[lCurrPos + 5] := ';';
|
|
inc(lCurrPos, 5);
|
|
end;
|
|
'"':
|
|
begin
|
|
if lCurrPos + 6 > Length(lRealString) then
|
|
SetLength(lRealString, lCurrPos + 16 + 6);
|
|
lRealString[lCurrPos + 1] := '&';
|
|
lRealString[lCurrPos + 2] := 'q';
|
|
lRealString[lCurrPos + 3] := 'u';
|
|
lRealString[lCurrPos + 4] := 'o';
|
|
lRealString[lCurrPos + 5] := 't';
|
|
lRealString[lCurrPos + 6] := ';';
|
|
inc(lCurrPos, 6);
|
|
end;
|
|
else
|
|
begin
|
|
if lCurrPos + 1 > Length(lRealString) then
|
|
SetLength(lRealString, lCurrPos + 16 + 1);
|
|
Inc(lCurrPos);
|
|
lRealString[lCurrPos] := lInputValue[i];
|
|
end;
|
|
end;
|
|
end;
|
|
SetLength(lRealString, lCurrPos);
|
|
WriteRawString(lRealString);
|
|
end;
|
|
initialization
|
|
RegisterMessageClass(TROXmlRpcMessage);
|
|
finalization
|
|
UnregisterMessageClass(TROXmlRpcMessage);
|
|
end.
|