unit uROPostMessage;

{----------------------------------------------------------------------------}
{ 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,
  uROSerializer, uROClient, uROClientIntf, uROTypes, FMTBcd;

type
  TROPostMessageSerializer = class;

  TROPostMessageBinaryType = (btInlineHex, btInlineBase64);

  TROPostMessage = class(TROMessage)
  private
    fBinaryType: TROPostMessageBinaryType;
    fMultiLine: Boolean;
    procedure SetBinaryType(const Value: TROPostMessageBinaryType);
  protected
    { Internals }
    function ReadException: 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 WriteException(aStream: TStream; anException: Exception); override;

    function GetSerializer: TROPostMessageSerializer;
    property Serializer: TROPostMessageSerializer read GetSerializer;
    procedure InitObject; override;
  public
    procedure Assign(aSource: TPersistent); override;
    function IsValidMessage(aData: PChar; aLength: Integer): boolean; override;
  published
    property BinaryType: TROPostMessageBinaryType read fBinaryType write SetBinaryType default btInlineHex;
    property MultiLine: Boolean read fMultiLine write fMultiLine default True;
  end;

  TROPostMessageSerializer = class(TROSerializer)
  private
    fPrefixStack: TStringList;
    fPrefix: String;
    fMessage: TStringList;
    fBinaryType: TROPostMessageBinaryType;
    procedure PushPrefix(aNewPrefix:string; aArrayElementId: integer = -1);
    procedure PopPrefix;
    function AssemblePrefix(const aName: string; aArrayElementId: integer): string;
  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 WriteXml(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 WriteVariant(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 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 ReadVariant(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;
    property BinaryType: TROPostMessageBinaryType read fBinaryType write fBinaryType;
  public
    constructor Create();
    destructor Destroy; override;

    procedure Clear();
    procedure LoadFromStream(aStream: TStream; aMultiLine: Boolean = True);
    procedure SaveToStream(aStream: TStream; aMultiLine: Boolean = True);

    procedure WriteItem(const aName: string; aString: string; aArrayElementId: integer = -1);
    function ReadItem(const aName: string; aArrayElementId: integer = -1): string;

    property Message: TStringList read fMessage write fMessage;
    property Prefix: string read fPrefix write fPrefix;
  end;

{$IFDEF DELPHI7UP}
const PostLocale = 1033;
var PostFormatSettings : TFormatSettings;
{$ENDIF DELPHI7}

implementation

uses
  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}eDebugServer,{$ENDIF}
  uRORes, uROClasses, uROCompression, uROBinaryHelpers, uROXmlIntf;

const
  PostDateTimeFormat = 'yyyy"-"mm"-"dd" "hh":"nn":"ss';
  PostDateTimeLength = 19;

function PostStrToFloat(const aString: string): Extended;
{$IFNDEF DELPHI7UP}
var e: integer;
{$ENDIF}
begin
  {$IFDEF DELPHI7UP}
  Result := StrToFloat(aString,PostFormatSettings);// then
  {$ELSE}
  Val(aString, Result, e);
  {$ENDIF}
end;

{ HTTPEncode/HTTPDecode reproduced from HTTPApp.pas}

function HTTPEncode(const AStr: String): String;
// The NoConversion set contains characters as specificed in RFC 1738 and
// should not be modified unless the standard changes.
const
  NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-',
                  '0'..'9','$','!','''','(',')'];
var
  Sp, Rp: PChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PChar(AStr);
  Rp := PChar(Result);
  while Sp^ <> #0 do begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else
      if Sp^ = ' ' then begin
        Rp^ := '+'
      end
      else begin
        FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
        Inc(Rp,2);
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PChar(Result));
end;

function HTTPDecode(const AStr: String): String;
var
  Sp, Rp, Cp: PChar;
  S: String;
begin
  SetLength(Result, Length(AStr));
  Sp := PChar(AStr);
  Rp := PChar(Result);
  Cp := Sp;
  try
    while Sp^ <> #0 do begin
      case Sp^ of
        '+': Rp^ := ' ';
        '%': begin
               // Look for an escaped % (%%) or %<hex> encoded character
               Inc(Sp);
               if Sp^ = '%' then begin
                 Rp^ := '%'
               end
               else begin
                 Cp := Sp;
                 Inc(Sp);
                 if (Cp^ <> #0) and (Sp^ <> #0) then begin
                   S := '$' + Cp^ + Sp^;
                   Rp^ := Chr(StrToInt(S));
                 end
                 else
                   raise Exception.CreateFmt('Error decoding character (%%XX) at position %d', [Cp - PChar(AStr)]);
               end;
             end;
      else
        Rp^ := Sp^;
      end;
      Inc(Rp);
      Inc(Sp);
    end;
  except
    on E:EConvertError do
      raise EConvertError.CreateFmt('Invalid URL encoded character (%s) at position %d', ['%' + Cp^ + Sp^, Cp - PChar(AStr)])
  end;
  SetLength(Result, Rp - PChar(Result));
end;

{ TROPostMessage }

procedure TROPostMessage.Assign(aSource: TPersistent);
begin
  inherited;
  if Assigned(aSource) then begin
    BinaryType := TROPostMessage(aSource).BinaryType;
    MultiLine := TROPostMessage(aSource).MultiLine;
  end;
end;

procedure TROPostMessage.InitObject;
begin
  inherited;
  fMultiLine := True;
end;

function TROPostMessage.CreateSerializer: TROSerializer;
begin
  result := TROPostMessageSerializer.Create();
  TROPostMessageSerializer(result).BinaryType := BinaryType;
end;

function TROPostMessage.GetSerializer: TROPostMessageSerializer;
begin
  result := (inherited Serializer as TROPostMessageSerializer);
end;

function GuidToStr(aGuid: TGUID): String;
begin
    result := GUIDToString(aGuid);
    result := copy(result, 2, length(result) - 2);
end;

procedure TROPostMessage.Initialize(const aTransport: IROTransport;
  const anInterfaceName, aMessageName: string; aType: TMessageType);
begin
  inherited;
  Serializer.Clear();
  Serializer.WriteItem('__MessageType','Message');
  Serializer.WriteItem('__InterfaceName',anInterfaceName);
  Serializer.WriteItem('__MessageName',aMessageName);
  Serializer.WriteItem('__ClientID', GuidToStr(Self.GetClientID()));
end;

function TROPostMessage.IsValidMessage(aData: PChar;
  aLength: Integer): boolean;
var
  str: string;
begin
  SetString(str, aData, aLength);
  Result := Pos('__MessageType=', str) > 0;
end;

function TROPostMessage.ReadException: Exception;
var
  lExceptionName, lMessage: string;
begin
  lExceptionName := Serializer.ReadItem('__ExceptionClass');
  lMessage := Serializer.ReadItem('__ExceptionMessage');

  result := CreateException(lExceptionName, lMessage);

  if result.InheritsFrom(EROException)
    then Serializer.Read('__Exception', result.ClassInfo, result); // Reads the other fields which have been properly serialized
end;

procedure TROPostMessage.ReadFromStream(aStream: TStream);
var
  lMessageType: string;
  lClientID: string;
begin
  inherited;
  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}
  DebugServer.EnterMethod('TROPostMessage.ReadFromStream(stream=%x; position:$%x)', [integer(pointer(aStream)), aStream.Position]);
  try
    DebugServer.WriteHexDump('Incoming PostMessage stream:', aStream);
    {$ENDIF DEBUG_REMOBJECTS_POSTMESSAGE}

  Serializer.LoadFromStream(aStream, fMultiLine);

  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}
  DebugServer.Write('Incoming PostMessage', Serializer.Message);
  {$ENDIF DEBUG_REMOBJECTS_POSTMESSAGE}

  lClientID := Serializer.ReadItem('__ClientID');
  if lClientID <> '' then
    SetClientID(StringToGUID(Format('{%s}', [lClientID])));

  lMessageType := Serializer.ReadItem('__MessageType');
  if SameText(lMessageType,'Message') then begin

    InterfaceName := Serializer.ReadItem('__InterfaceName');
    MessageName := Serializer.ReadItem('__MessageName');

  end
  else if SameText(lMessageType, 'Exception') then begin
    ProcessException();
  end
  else begin
    raise EROException.CreateFmt(err_UnknownMessageType,[lMessageType]);
  end;

  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}
  finally
    DebugServer.ExitMethod('TROPostMessage.ReadFromStream(stream=%x; position:$%x)', [integer(pointer(aStream)), aStream.Position]);
  end;
  {$ENDIF DEBUG_REMOBJECTS_POSTMESSAGE}
end;

procedure TROPostMessage.SetBinaryType(
  const Value: TROPostMessageBinaryType);
begin
  if fBinaryType <> Value then begin
    fBinaryType := Value;
    Serializer.BinaryType := Value;
  end;
end;

procedure TROPostMessage.WriteException(aStream: TStream; anException: Exception);
begin
  Serializer.Clear();
  Serializer.WriteItem('__MessageType','Exception');
  Serializer.WriteItem('__ExceptionClass', anException.ClassName);
  Serializer.WriteItem('__ExceptionMessage', anException.Message);

  if (anException is EROException) then begin
    Serializer.Write('__Exception', anException.ClassInfo, anException);
  end;

  WriteToStream(aStream);
  inherited;
end;

procedure TROPostMessage.WriteToStream(aStream: TStream);
begin
  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}
  DebugServer.Write('Outgoing PostMessage', Serializer.Message);
  {$ENDIF DEBUG_REMOBJECTS_POSTMESSAGE}

  Serializer.SaveToStream(aStream, MultiLine);
  aStream.Seek(0, soFromBeginning);

  inherited;
  {$IFDEF DEBUG_REMOBJECTS_POSTMESSAGE}
  DebugServer.WriteHexDump('Outgoing PostMessage stream:', aStream);
  {$ENDIF DEBUG_REMOBJECTS_POSTMESSAGE}
end;

{ TROPostMessageSerializer }

constructor TROPostMessageSerializer.Create;
begin
  fMessage := TStringList.Create();
  fPrefixStack := TStringList.Create();
end;

destructor TROPostMessageSerializer.Destroy;
begin
  FreeAndNil(fMessage);
  FreeAndNil(fPrefixStack);
  inherited;
end;

procedure TROPostMessageSerializer.BeginReadObject(const aName: string;
  aClass: TClass; var anObject: TObject; var LevelRef: IInterface;
  var IsValidType: boolean; ArrayElementId: integer);
var
  lCount: Integer;
  lIsAssigned: Boolean;
  lActualClass: TROComplexTypeClass;
  lClassname: string;
begin
  inherited;
  lClassname := ReadItem(aName, ArrayElementID);

  lIsAssigned := lClassname <> '';

  PushPrefix(aName, ArrayElementId);

  { ToDo -omh: MUCH this should be moved into common code in TROSerializer so ALL messages benbefit from it? }

  if aClass.InheritsFrom(TROArray) then begin
    if lIsAssigned then begin
      anObject := aClass.Create();
      ReadInteger('Count', otULong, lCount);
      TROArray(anObject).Resize(lCount);
    end;
    IsValidType := true;
  end
  else if aClass.InheritsFrom(Binary) then begin
    if not Assigned(anObject) then begin
      if lIsAssigned then
        anObject := Binary.Create;
    end
    else begin
      if lIsAssigned then begin
        (anObject as Binary).Size := 0;
      end
      else begin
        anObject := nil;
      end;
    end;
    IsValidType := true;
  end
  else if Assigned(anObject) and aClass.InheritsFrom(EROException) then begin
    IsValidType := TRUE;
  end
  else begin
    if lIsAssigned then begin

      if IsValidType then begin
        lActualClass := FindROClass(lClassname);
        if not Assigned(lActualClass) then RaiseError(err_UnknownClassInStream,[lClassname,aClass.ClassName]);
        if not lActualClass.InheritsFrom(aClass) then RaiseError(err_UnexpectedClassInStream,[lClassname,aClass.ClassName]);
        anObject := lActualClass.Create;

      end
      else begin
        RaiseError(str_InvalidClassTypeInStream,[lClassname]);
      end;
    end;
  end;

end;

procedure TROPostMessageSerializer.EndReadObject(const aName: string; aClass: TClass; var anObject: TObject; const LevelRef: IInterface);
begin
  inherited;
  PopPrefix();
end;

procedure TROPostMessageSerializer.BeginWriteObject(const aName: string;
  aClass: TClass; anObject: TObject; var LevelRef: IInterface;
  var IsValidType: boolean; out IsAssigned: Boolean;
  ArrayElementId: integer);
var
  lCount: Integer;
begin
  inherited;
  IsAssigned := Assigned(anObject);

  if aClass.InheritsFrom(Binary) then
    IsValidType := true;


  if IsValidType and IsAssigned then
    WriteItem(aName, anObject.ClassName, ArrayElementId)
  else
    WriteItem(aName, '', ArrayElementId);

  PushPrefix(aName, ArrayElementId);

  if IsAssigned and (anObject is TROArray) then begin
    lCount := TROArray(anObject).Count;
    WriteInteger('Count', otULong, lCount);
  end;
end;

procedure TROPostMessageSerializer.EndWriteObject(const aName: string; aClass: TClass; anObject: TObject; const LevelRef: IInterface);
begin
  inherited;
  PopPrefix();
end;

procedure TROPostMessageSerializer.ReadDateTime(const aName: string; var Ref; ArrayElementId: integer);
var
  year, month, day, hour, min, sec : word;
  S: string;
begin
  s := HTTPDecode(ReadItem(aName, ArrayElementId));
  if s = '' then begin
    TDateTime(Ref) := 0;
  end
  else begin
    if Length(s) <> 19 then
      RaiseError('Invaild DateTime value %s in PostMessage ("%s")',[s]);

    year  := StrToInt(Copy(s,1,4));
    month := StrToInt(Copy(s,6,2));
    day   := StrToInt(Copy(s,9,2));
    hour  := StrToInt(Copy(s,12,2));
    min   := StrToInt(Copy(s,15,2));
    sec   := StrToInt(Copy(s,18,2));
    TDateTime(Ref) := EncodeDate(year, month, day)+EncodeTime(hour, min, sec, 0);
  end;
end;

procedure TROPostMessageSerializer.WriteDateTime(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  WriteItem(aName,FormatDateTime(PostDateTimeFormat,TDateTime(Ref)), ArrayElementId);
end;

procedure TROPostMessageSerializer.ReadDouble(const aName: string; aFloatType: TFloatType; var Ref; ArrayElementId: integer);
var
  text: string;
begin
  text := ReadItem(aName, ArrayElementId);
  case aFloatType of
    ftSingle : single(Ref) := PostStrToFloat(text);
    ftDouble : double(Ref) := PostStrToFloat(text);
    ftExtended : extended(Ref) := PostStrToFloat(text);
    ftComp : comp(Ref) := PostStrToFloat(text);
    ftCurr : currency(Ref) := PostStrToFloat(text);
  end
end;

procedure TROPostMessageSerializer.WriteDouble(const aName: string; aFloatType: TFloatType; const Ref; ArrayElementId: integer);
var
  src: pointer;
  text: string;
begin
  src := @Ref;
  case aFloatType of
    ftSingle   : begin
      text := FloatToStr(single(src^){$IFDEF DELPHI7UP}, PostFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftDouble   : begin
      text := FloatToStr(double(src^){$IFDEF DELPHI7UP}, PostFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftExtended : begin
      text := FloatToStr(extended(src^){$IFDEF DELPHI7UP}, PostFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftComp     : begin
      text := FloatToStr(comp(src^){$IFDEF DELPHI7UP}, PostFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftCurr     : begin
      text := FloatToStr(currency(src^){$IFDEF DELPHI7UP}, PostFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
  end;
  ReplaceChar(text,[','],'.'); { compensate for locales that use "," as decimal. }
  WriteItem(aName,text,ArrayElementId);
end;

procedure TROPostMessageSerializer.ReadEnumerated(const aName: string; anEnumTypeInfo: PTypeInfo; var Ref; ArrayElementId: integer);
var
  value: Integer;
  text: string;
begin
  text := ReadItem(aName, ArrayElementId);
  value := GetEnumValue(anEnumTypeInfo, text);
  byte(Ref) := value;
end;

procedure TROPostMessageSerializer.WriteEnumerated(const aName: string; anEnumTypeInfo: PTypeInfo; const Ref; ArrayElementId: integer);
begin
  WriteItem(aName,GetEnumName(anEnumTypeInfo, Ord(byte(Ref))), ArrayElementId);
end;

procedure TROPostMessageSerializer.ReadInt64(const aName: string; var Ref; ArrayElementId: integer);
var
  s: string;
begin
  s := ReadItem(aName, ArrayElementId);
  Int64(Ref) := StrToInt(s);
end;

procedure TROPostMessageSerializer.ReadInteger(const aName: string; anOrdType: TOrdType; var Ref; ArrayElementId: integer);
var
  s: string;
begin
  s := ReadItem(aName, ArrayElementId);
  case anOrdType of
    otSByte:smallint(ref) := StrToInt(s);
    otUByte:byte(ref) := StrToInt(s);
    otSWord:shortint(ref) := StrToInt(s);
    otUWord:word(ref) := StrToInt(s);
    otSLong:longint(ref) := StrToInt(s);
    otULong:cardinal(ref) := StrToInt(s);
  end;
end;

procedure TROPostMessageSerializer.ReadUTF8String(const aName: string; var Ref;
  ArrayElementId, iMaxLength: integer);
begin
  string(ref) := HTTPDecode(ReadItem(aName, ArrayElementId));
end;

procedure TROPostMessageSerializer.ReadWideString(const aName: string; var Ref;
  ArrayElementId, iMaxLength: integer);
begin
  WideString(ref) := UTF8Decode(HTTPDecode(ReadItem(aName, ArrayElementId)));
end;

procedure TROPostMessageSerializer.WriteInt64(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  WriteItem(aName,IntToStr(Int64(ref)), ArrayElementId);
end;

procedure TROPostMessageSerializer.WriteInteger(const aName: string; anOrdType: TOrdType; const Ref; ArrayElementId: integer);
var
  s: string;
begin
  case anOrdType of
    otSByte:s := IntToStr(smallint(ref));
    otUByte:s := IntToStr(byte(ref));
    otSWord:s := IntToStr(shortint(ref));
    otUWord:s := IntToStr(word(ref));
    otSLong:s := IntToStr(longint(ref));
    otULong:s := IntToStr(cardinal(ref));
  end;
  WriteItem(aName,s, ArrayElementId);
end;

procedure TROPostMessageSerializer.WriteUTF8String(const aName: string; const Ref; ArrayElementId: integer);
begin
  WriteItem(aName,HTTPEncode(string(ref)), ArrayElementId);
end;

procedure TROPostMessageSerializer.WriteWideString(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  WriteItem(aName, HTTPEncode(UTF8Encode(WideString(Ref))), ArrayElementID);
end;

procedure TROPostMessageSerializer.Clear;
begin
  fMessage.Clear();
  fPrefixStack.Clear();
  fPrefix := '';
end;

procedure TROPostMessageSerializer.LoadFromStream(aStream: TStream; aMultiLine: Boolean = True);
var
  s: string;
begin
  if aMultiLine then
    fMessage.LoadFromStream(aStream)
  else begin
    SetLength(s,aStream.Size);
    aStream.ReadBuffer(Pointer(s)^, Length(s));
    fMessage.Delimiter := '&';
    fMessage.DelimitedText := s;
  end;
  if (fMessage.Count > 0) and (copy(fMessage[0], 1, 7) = 'rorocks') then
    RaiseInvalidStreamError(err_InvalidHeaderEncrypted, [], aStream);

  fPrefixStack.Clear();
  fPrefix := '';
end;

procedure TROPostMessageSerializer.SaveToStream(aStream: TStream; aMultiLine: Boolean = True);
var
  s: string;
begin
  if not aMultiLine then begin
    fMessage.Delimiter := '&';
    s := fMessage.DelimitedText;
    aStream.WriteBuffer(Pointer(s)^, Length(s));
  end
  else begin
    fMessage.SaveToStream(aStream);
  end;
end;

procedure TROPostMessageSerializer.PopPrefix;
begin
  if fPrefixStack.Count = 0 then
    raise EROException.Create('Umatched call to PopPrefix');

  Prefix := fPrefixStack[fPrefixStack.Count-1];
  fPrefixStack.Delete(fPrefixStack.Count-1);
end;

procedure TROPostMessageSerializer.PushPrefix(aNewPrefix: string; aArrayElementId: integer = -1);
begin
  fPrefixStack.Add(Prefix);
  Prefix := AssemblePrefix(aNewPrefix,aArrayElementId);
end;

procedure TROPostMessageSerializer.CustomReadObject(const aName: string; aClass: TClass; var Ref; ArrayElementId: integer);
var
  obj: TObject absolute Ref;
begin
  inherited;
  if Assigned(obj) and (obj is Binary) then begin
    ReadBinary('Value', Binary(obj), ArrayElementID);
  end;
end;

procedure TROPostMessageSerializer.CustomWriteObject(const aName: string; aClass: TClass; const Ref; ArrayElementId: integer);
var
  obj: TObject absolute Ref;
begin
  inherited;
  if Assigned(obj) and (obj is Binary) then begin
    WriteBinary('Value', Binary(obj), ArrayElementID);
  end;
end;

procedure TROPostMessageSerializer.ReadVariant(const aName: String; var Ref; ArrayElementId: Integer);
var
  lBinary: Binary;
begin
  lBinary := Binary.Create();
  try
    ReadBinary(aName, lBinary, ArrayElementID);
    variant(Ref) := VariantFromBinary(lBinary);
  finally
    lBinary.Free();
  end;
end;

procedure TROPostMessageSerializer.WriteVariant(const aName: String; const Ref; ArrayElementId: Integer);
var
  lBinary: Binary;
begin
  lBinary := BinaryFromVariant(Variant(Ref));
  try
    WriteBinary(aName, lBinary, ArrayElementID);
  finally
    lBinary.Free();
  end;
end;

function TROPostMessageSerializer.AssemblePrefix(const aName: string; aArrayElementId: integer):string;
begin
  if Prefix <> '' then begin
    if aArrayElementID <> -1 then begin
      result := Prefix+'['+IntToStr(aArrayElementID)+']';
    end
    else begin
      result := Prefix+'.'+aName;
    end;
  end
  else begin
    result := aName;
  end;
end;

procedure TROPostMessageSerializer.WriteItem(const aName: string; aString: string; aArrayElementId: integer = -1);
begin
  Message.Add(AssemblePrefix(aName, aArrayElementID)+'='+aString)
end;

function TROPostMessageSerializer.ReadItem(const aName: string; aArrayElementId: integer = -1):string;
begin
  result := Message.Values[AssemblePrefix(aName, aArrayElementId)];
end;

procedure TROPostMessageSerializer.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 TROPostMessageSerializer.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 TROPostMessageSerializer.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 TROPostMessageSerializer.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 TROPostMessageSerializer.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 TROPostMessageSerializer.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 TROPostMessageSerializer.WriteBinary(const aName: string;
  const Ref; ArrayElementId: integer);
var
  obj : Binary absolute Ref;
  ss: TStringStream;
  s: string;
begin
  if Assigned(obj) then begin
    WriteItem(aName, obj.ClassName, ArrayElementId);
    
    PushPrefix(aName, ArrayElementId);
    try
      case BinaryType of
        btInlineHex:begin
            s := obj.ToHexString;
          end;
        btInlineBase64:begin
            ss := TStringStream.Create('');
            try
              obj.Position := 0;
              EncodeStream(obj, ss);
              s := ss.DataString;
            finally
              ss.Free;
            end;
          end;
      end;
      WriteItem('Value', s, ArrayElementID);
    finally
      PopPrefix();
    end;
  end  
  else
    WriteItem(aName, '', ArrayElementId);
end;

procedure TROPostMessageSerializer.ReadBinary(const aName: string; var Ref;
  ArrayElementId: integer);
var
  obj : Binary absolute Ref;
  ss: TStringStream;
  s: string;
begin
  if ReadItem(aName, ArrayElementID) <> '' then begin
    if not Assigned(obj) then Obj := Binary.Create;
    obj.Size := 0;
    PushPrefix(aName, ArrayElementId);
    s := ReadItem('Value', ArrayElementID);
    PopPrefix;
    case BinaryType of
      btInlineHex: Obj.LoadFromString(StringFromHexString(s));
      btInlineBase64:begin
        ss := TStringStream.Create(s);
        try
          DecodeStream(ss, Obj);
          Obj.Position := 0;
        finally
          ss.Free;
        end;
      end;
    end;
  end
  else
    obj:=nil;
end;

function TROPostMessageSerializer.ReadArray(const aName: string;
  aClass: TClass; var Ref; ArrayElementId: integer): Boolean;
var
  obj : TROArray absolute Ref;
  lCount: Integer;
begin
  Result:= ReadItem(aName, ArrayElementID) <> '';
  if Result then begin
    PushPrefix(aName, ArrayElementId);
    obj := TROArray(aClass.Create());
    ReadInteger('Count', otULong, lCount);
    obj.Resize(lCount);
    obj.ReadComplex(Self);
    PopPrefix();
  end;
end;

function TROPostMessageSerializer.ReadStruct(const aName: string;
  aClass: TClass; var Ref; ArrayElementId: integer): Boolean;
var
  obj : TROComplexType absolute Ref;
  lActualClass: TROComplexTypeClass;
  lClassname: string;
begin
  inherited;
  lClassname := ReadItem(aName, ArrayElementID);
  Result:=lClassname <> '';
  if Result then begin
    lActualClass := FindROClass(lClassname);
    if not Assigned(lActualClass) then RaiseError(err_UnknownClassInStream,[lClassname,aClass.ClassName]);
    if not lActualClass.InheritsFrom(aClass) then RaiseError(err_UnexpectedClassInStream,[lClassname,aClass.ClassName]);
    obj := lActualClass.Create;
    PushPrefix(aName, ArrayElementId);
    Obj.ReadComplex(Self);
    PopPrefix;
  end;
end;

procedure TROPostMessageSerializer.WriteArray(const aName: string;
  const Ref; ArrayElementId: integer);
var
  obj : TROArray absolute Ref;
  lCount: Integer;
begin
  if Assigned(obj) then begin
    WriteItem(aName, obj.ClassName, ArrayElementId);
    PushPrefix(aName, ArrayElementId);
    lCount := obj.Count;
    WriteInteger('Count', otULong, lCount);
    obj.WriteComplex(Self);
    PopPrefix();
  end
  else
    WriteItem(aName, '', ArrayElementId);
end;

procedure TROPostMessageSerializer.WriteStruct(const aName: string;
  const Ref; ArrayElementId: integer);
var
  obj : TROComplexType absolute Ref;
begin
  if Assigned(obj) then begin
    WriteItem(aName, obj.ClassName, ArrayElementId);
    PushPrefix(aName, ArrayElementId);
    obj.WriteComplex(Self);
    PopPrefix();
  end
  else
    WriteItem(aName, '', ArrayElementId);
end;

procedure TROPostMessageSerializer.ReadException(const aName: string;
  var Ref; ArrayElementId: integer);
var
  obj: EROException absolute Ref;
  lIsAssigned: Boolean;
  lClassname: string;
begin
  lClassname := ReadItem(aName, ArrayElementID);
  lIsAssigned := lClassname <> '';
  PushPrefix(aName, ArrayElementId);
  try
    if lIsAssigned and Assigned(obj) then obj.ReadException(Self);
  finally
    PopPrefix;
  end;
end;

procedure TROPostMessageSerializer.WriteException(const aName: string;
  const Ref; ArrayElementId: integer);
var
  obj: EROException absolute Ref;
begin
  if Assigned(obj) then
    WriteItem(aName, obj.ClassName, ArrayElementId)
  else
    WriteItem(aName, '', ArrayElementId);
  PushPrefix(aName, ArrayElementId);
  try
    if Assigned(obj) then obj.WriteException(Self);
  finally
    PopPrefix;
  end;
end;

initialization
  RegisterMessageClass(TROPostMessage);
  {$IFDEF DELPHI7UP}
  GetLocaleFormatSettings(PostLocale,PostFormatSettings);
  {$ENDIF}

end.