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.