unit uROJSONMessage;

{----------------------------------------------------------------------------}
{ 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
  Classes, SysUtils, TypInfo, uROTypes, uROHttpTools,
  uROSerializer, uROClient, uROClientIntf, uROJSONParser;

type
  TROJSONMessage = class;
  EROJSONSerializerException = class(Exception);
  TROJSONSerializer = class(TROSerializer)
  private
    fOwner: TROJSONMessage;
    fArrayIndex: Integer;
    fNested: Boolean;

    function IntReadObject(const aName: string): TROJSONValue;
    procedure IntWriteObject(const aName: string; obj: Variant);

  protected
  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 WriteAnsiString(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; aClass: TClass = nil; ArrayElementId : integer = -1); override;
    procedure WriteArray(const aName : string; const Ref; aClass: TClass = nil; 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 ReadAnsiString(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); override;
  public
    constructor Create(aOwner: TROJSONMessage);

  end;

  TROJSONMessage = class(TROMessage)
  private
    fIndent,
    fWrapResult,
    fParamsAsArray,
    fHaveResult,
    fSessionIdAsId: Boolean;
    FCurrObject: TROJSONValue;
    FRoot: TROJSONValue;
    fMessageType: TMessageType;
    fId: string;
  protected
    { Internals }
    function ReadException: Exception; override;
    procedure WriteException(aStream: TStream; anException: Exception); override;

    function CreateSerializer: TROSerializer; override;

    procedure IntInitializeMessage;
    { 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;
    function GetMessageType: TMessageType; override;
      
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function IsValidMessage(aData: PAnsiChar; aLength: Integer): boolean; override;
    property Id: string read fId write fId;
  published
    property SessionIdAsId: Boolean read fSessionIdAsId write fSessionIdAsId default false;
    property WrapResult: Boolean read fWrapResult write fWrapResult default false;
    property ParamsAsArray: Boolean read fParamsAsArray write fParamsAsArray default false;
    property Indent: Boolean read fIndent write fIndent default false;
  end;

implementation
uses
  uROCompression, uROBinaryHelpers, FMTBcd, uROClasses, Variants, uROXmlIntf;
{ TROJSONSerializer }

{$IFDEF DELPHI7UP}
const SOAPLocale = 1033;
var SOAPFormatSettings : TFormatSettings;
{$ENDIF DELPHI7}


constructor TROJSONSerializer.Create(aOwner: TROJSONMessage);
begin
  fOwner := aOwner;
end;

function TROJSONSerializer.ReadArray(const aName: string; aClass: TClass;
  var Ref; ArrayElementId: integer): Boolean;
var
  lItem: TROJSONValue;
  lOld: TROJSONValue;
begin
  lOld := fOwner.FCurrObject;
  result := true;
  lItem := IntReadObject(aName);
  if lItem = nil then begin
    TROArray(Ref) := nil;
    exit;
  end;
  TROArray(Ref) := TROArrayClass(aClass).Create;
  TROArray(Ref).Resize(lItem.AsArray.Count);
  fOwner.FCurrObject := lItem;
  fArrayIndex := 0;
  try
    TROArray(Ref).ReadComplex(self);
  finally
    fOwner.FCurrObject := lOld;
  end;
end;

function TROJSONSerializer.ReadStruct(const aName: string; aClass: TClass;
  var Ref; ArrayElementId: integer): Boolean;
var
  lItem: TROJSONValue;
  lSave: Boolean;
  lOld: TROJSONValue;
begin
  lOld := fOwner.FCurrObject;
  result := true;
  lItem := IntReadObject(aName);
  if lItem = nil then begin
    TROComplexType(Ref) := nil;
    exit;
  end;
  TROComplexType(Ref) := TROComplexTypeClass(aClass).Create;
  lSave := fNested;
  fNested := true;
  fOwner.FCurrObject := lItem;
  try
    TROComplexType(Ref).ReadComplex(self);
  finally
    fNested := lSAve;
    fOwner.FCurrObject := lOld;
  end;
end;

procedure TROJSONSerializer.ReadException(const aName: string; var Ref;
  ArrayElementId: integer);
begin
  // not used
end;

procedure TROJSONSerializer.WriteException(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  // not used
end;

procedure TROJSONSerializer.WriteArray(const aName: string; const Ref;
  aClass: TClass; ArrayElementId: integer);
var
  lOld: TROJSONValue;
begin
  if TROComplexType(Ref) = nil then exit;
  lOld := fOwner.FCurrObject;
  try
    if (fOwner.GetMessageType =mtResponse) and (not fOWner.fWrapResult) and (fOwner.FCurrObject = nil) then begin
      if fOwner.fHaveResult then begin
        raise EROJSONSerializerException.Create('Only one result allowed when WrapResult is false');
      end;
      fOwner.fHaveResult := true;
      fOwner.FCurrObject := fOwner.FRoot.AsObject.AddArrayProperty('result');
    end else begin
      if fOwner.FCurrObject.ValueType = jdtArray then
        fOwner.FCurrObject := fOwner.FCurrObject.AsArray.AddArrayValue()
      else
        fOwner.FCurrObject := fOwner.FCurrObject.AsObject.AddArrayProperty(aName);
    end;
    TROComplexType(Ref).WriteComplex(Self);
  finally
    fOwner.FCurrObject := lOld;
  end;
end;

procedure TROJSONSerializer.WriteStruct(const aName: string; const Ref;
  aClass: TClass; ArrayElementId: integer);
var
  lOld: TROJSONValue;
begin
  if TROComplexType(Ref) = nil then exit;
  lOld := fOwner.FCurrObject;
  try
    if (fOwner.GetMessageType =mtResponse) and (not fOWner.fWrapResult) and (fOwner.FCurrObject = nil) then begin
      if fOwner.fHaveResult then begin
        raise EROJSONSerializerException.Create('Only one result allowed when WrapResult is false');
      end;
      fOwner.fHaveResult := true;
      fOwner.FCurrObject := fOwner.FRoot.AsObject.AddObjectProperty('result');
    end else begin
      if fOwner.FCurrObject.ValueType = jdtArray then
        fOwner.FCurrObject := fOwner.FCurrObject.AsArray.AddObject()
      else
        fOwner.FCurrObject := fOwner.FCurrObject.AsObject.AddObjectProperty(aName);
    end;
    TROComplexType(Ref).WriteComplex(Self);
  finally
    fOwner.FCurrObject := lOld;
  end;
end;


function TROJSONSerializer.IntReadObject(
  const aName: string): TROJSONValue;
var
  lArr: TROJSONArray;
begin
  if (fOwner.GetMessageType =mtResponse) and (not fOWner.fWrapResult) and (not fNested) then begin
    if fOwner.fHaveResult then begin
      result := nil;
    end else begin
      fOwner.fHaveResult := true;
      result := fOwner.FCurrObject;
    end;
  end else if fOwner.FCurrObject.ValueType  = jdtArray then begin
    lArr := fOwner.FCurrObject.ASArray;
    if fArrayIndex < lArr.Count then begin
      result := lArr[fArrayIndex];
      inc(fArrayIndex);
    end else
      result := nil;
  end else begin
    result := fOwner.FCurrObject.AsObject.FindItem(aName);
  end;
end;

procedure TROJSONSerializer.IntWriteObject(const aName: string;
  obj: Variant);
begin
  if (fOwner.GetMessageType =mtResponse) and (not fOWner.fWrapResult) and (fOwner.FCurrObject = nil) then begin
    if fOwner.fHaveResult then begin
      raise EROJSONSerializerException.Create('Only one result allowed when WrapResult is false');
    end;
    fOwner.fHaveResult := true;
    fOwner.FRoot.AsObject.AddVariantProperty('result', obj);
  end else begin
    if fOwner.FCurrObject.ValueType = jdtArray then
      fOwner.FCurrObject.AsArray.AddVariantValue(obj)
    else
      fOwner.FCurrObject.AsObject.AddVariantProperty(aName, obj);
  end;
end;

procedure TROJSONSerializer.ReadAnsiString(const aName: string; var Ref;
  ArrayElementId, iMaxLength: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then
    String(ref) := ''
  else
    String(ref) := lItem.AsString;
end;

procedure TROJSONSerializer.ReadBinary(const aName: string; var Ref;
  ArrayElementId: integer);
var
  obj: Binary absolute Ref;
  lItem: TROJSONValue;
  ss: TStringStream;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then Obj := nil else begin
    obj:= Binary.Create;
    ss := TStringStream.Create(lITem.AsString);
    try
      obj.Clear;
      DecodeStream(ss, TMemoryStream(obj));
      TMemoryStream(obj).Position := 0;
    finally
      ss.Free;
    end;
  end;
end;

function SOAPDateTimeToDateTime(const aSOAPDate : string; out Offset: Integer) : TDateTime;
var year, month, day, hour, min, sec : word;
  msec: double;
 { ldummy,} i: Integer;
  s: string;
begin
  // This probabily will all change. See W3C specs for date/time
  case Length(aSOAPDate) of
    10 : begin {yyyy-mm-dd}
      year  := StrToInt(Copy(aSOAPDate,1,4));
      month := StrToInt(Copy(aSOAPDate,6,2));
      day   := StrToInt(Copy(aSOAPDate,9,2));
      result := EncodeDate(year, month, day);
    end;
    8 : begin {hh:nn:ss}
      hour  := StrToInt(Copy(aSOAPDate,1,2));
      min   := StrToInt(Copy(aSOAPDate,4,2));
      sec   := StrToInt(Copy(aSOAPDate,7,2));
      result := EncodeTime(hour, min, sec, 0);
    end;
    else {SOAP_DateTimeFormatLength : } begin {yyyy-mm-ddThh:nn:ss}
      year  := StrToInt(Copy(aSOAPDate,1,4));
      month := StrToInt(Copy(aSOAPDate,6,2));
      day   := StrToInt(Copy(aSOAPDate,9,2));
      hour  := StrToInt(Copy(aSOAPDate,12,2));
      min   := StrToInt(Copy(aSOAPDate,15,2));
      sec   := StrToInt(Copy(aSOAPDate,18,2));
      s := copy(aSOAPDate, 20, MaxInt);
      if (Length(s) > 1) and (s[1] = '.') then begin
        i := LastDelimiter('+-Z', s);
        if i > 0 then begin
          msec := StrToFloatDef('0'+DecimalSeparator+Copy(s, 2, i-2), 0);
         // Val(Copy(s, 1, i -1), msec, ldummy);
          delete(s, 1, i-1);
        end else begin
          msec := StrToFloatDef('0'+DecimalSeparator+copy(s, 2, MaxInt), 0);
          //Val(s, msec, ldummy);
          s := '';
        end;
        msec := msec * (1.0 / 60.0 / 60.0 / 24);
      end else
        msec := 0;

      result := EncodeDate(year, month, day);
      // The code below is required! Do not adjust
      if (result<0) then begin
        result := result-EncodeTime(hour, min, sec, 0);
        result := result - msec;
      end else begin
        result := result+EncodeTime(hour, min, sec, 0);
        result := result + msec;
      end;
      Offset := MaxInt;
      if (Length(s) <> 0) and ((s[1] = 'z') or (s[1] = 'Z')) then Offset := 0 else
      if (Length(s) > 0) and ((s[1] = '+') or (s[1] = '-')) then begin
        if s[1] = '-' then i := -1 else i := 1;
        Delete(s,1,1);
        if pos(':', s) > 0 then begin
          hour := StrToInt(copy(s,1,Pos(':', s)-1));
          delete(s,1,pos(':', s));
          min := StrToInt(s);
        end else begin
          hour := StrToInt(s);
          min := 0;
        end;

        if i = -1 then
          Offset := - (min + 60 * hour)
        else
          Offset := + (min + 60 * hour);
      end;
    end;
  end;
end;

const
  SOAP_DateTimeFormat       = 'yyyy-mm-dd"T"hh":"nn":"ss';

  function DateTimeToSOAPDateTime(aDateTime : TDateTime) : string;
begin
  result := FormatDateTime(SOAP_DateTimeFormat, aDateTime);
end;


procedure TROJSONSerializer.ReadDateTime(const aName: string; var Ref;
  ArrayElementId: integer);
var
  lItem: TROJSONValue;
  lOffset: Integer;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then
    raise EROJSONSerializerException.Create('Field not found');
  TDateTime(Ref) := SOAPDateTimeToDateTime(lItem.AsString, lOffset);
end;

procedure TROJSONSerializer.ReadDecimal(const aName: String; var Ref;
  ArrayElementId: Integer);
var
  lItem: TROJSONValue;
  s: string;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  s := lItem.AsString;

  if DecimalSeparator <> '.' then s := StringReplace(s, '.', DecimalSeparator, []);
 Variant(Ref) := BCDToVariant(StrToBcd(s));
end;

function SOAPStrToFloat(const aString: string): Extended;
begin
  {$IFDEF DELPHI7UP}
  Result := StrToFloat(aString,SOAPFormatSettings);// then
  {$ELSE}
  Result := StrToFloat(StringReplace(aString, '.', DecimalSeparator, []));
  {$ENDIF}
end;

procedure TROJSONSerializer.ReadDouble(const aName: string;
  aFloatType: TFloatType; var Ref; ArrayElementId: integer);
var
  lItem: TROJSONValue;
  text: string;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  text := lItem.AsString;

    {$IFNDEF DELPHI7UP}
      if DecimalSeparator <> '.' then
        ReplaceChar(text, ['.'], DecimalSeparator);
    {$ELSE}
    if DecimalSeparator <> SOAPFormatSettings.DecimalSeparator then
       ReplaceChar(text, [DecimalSeparator], SOAPFormatSettings.DecimalSeparator);
    {$ENDIF}
    case aFloatType of
      ftSingle : single(Ref) := SOAPStrToFloat(text);
      ftDouble : double(Ref) := SOAPStrToFloat(text);
      ftExtended : extended(Ref) := SOAPStrToFloat(text);
      ftComp : comp(Ref) := {$IFDEF FPC}
                              {$IFDEF cpu64}StrToInt64(text){$ELSE}StrToInt(text){$ENDIF}
                            {$ELSE}
                               SOAPStrToFloat(text)
                            {$ENDIF};
      ftCurr : currency(Ref) := SOAPStrToFloat(text);
    end;
end;

procedure TROJSONSerializer.ReadEnumerated(const aName: string;
  anEnumTypeInfo: PTypeInfo; var Ref; ArrayElementId: integer);
var
  lItem: TROJSONValue;
  s: string;
  lIndexInEnum: Integer;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  if anEnumTypeInfo = typeinfo(Boolean) then begin
     if Boolean(lItem.VarValue) then byte(Ref) := 1 else byte(Ref) := 0;
  end
  else begin
     s := lItem.AsString;
     lIndexInEnum  := ROGetEnumValue(anEnumTypeInfo, s);
     if lIndexInEnum = -1 then begin
       lIndexInEnum  := ROGetEnumValue(anEnumTypeInfo, {$IFDEF UNICODE}UTF8ToString{$ENDIF}(anEnumTypeInfo.Name)+'_'+s);
       if lIndexInEnum = -1 then
          RaiseError(Format('The value "-1" for parameter "%s" of "%s" type is invalid', [aName, anEnumTypeInfo^.Name]));
     end;
     byte(Ref) := lIndexInEnum;
  end;
end;

procedure TROJSONSerializer.ReadGuid(const aName: String; var Ref;
  ArrayElementId: Integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  String(Ref) := lItem.AsString;
  if Length(String(Ref)) > 0 then begin
    if String(Ref)[1] <> '{' then String(Ref) := '{'+String(Ref)+'}';
  end;
end;

procedure TROJSONSerializer.ReadInt64(const aName: string; var Ref;
  ArrayElementId: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  Int64(Ref) := StrToInt64(lITem.AsString);
end;

procedure TROJSONSerializer.ReadInteger(const aName: string;
  anOrdType: TOrdType; var Ref; ArrayElementId: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then raise EROJSONSerializerException.Create('Field not found');
  case anOrdType of
    otSByte,
    otUByte : byte(Ref) := StrToInt(lItem.AsString);
    otSWord,
    otUWord : word(Ref) := StrToInt(lItem.AsString);
    otSLong,
    otULong : integer(Ref) := StrToInt(lItem.AsString);
  end;
end;

procedure TROJSONSerializer.ReadUTF8String(const aName: string; var Ref;
  ArrayElementId, iMaxLength: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then
    UTF8String(ref) := ''
  else
    UTF8String(ref) := UTF8Encode(lItem.AsString);
end;

procedure TROJSONSerializer.ReadVariant(const aName: string; var Ref;
  ArrayElementId: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then
    Variant(Ref) := Null
  else
    Variant(ref) := lItem.VarValue;
end;

procedure TROJSONSerializer.ReadWideString(const aName: string; var Ref;
  ArrayElementId, iMaxLength: integer);
var
  lItem: TROJSONValue;
begin
  lItem := IntReadObject(aName);
  if lItem = nil then
    WideString(ref) := ''
  else
    WideString(ref) := lItem.AsString;
end;

procedure TROJSONSerializer.ReadXml(const aName: string; var Ref;
  ArrayElementId: integer);
var
  w: WideString;
  doc: IXMLDocument;
begin
  ReadWideString(aName, w);
   if w = '' then
    IXMLNode(Ref) := nil
  else begin
    doc := NewROXmlDocument;
    doc.New;
    doc.XML := w;
    IXMLNode(Ref) := doc.DocumentNode;
  end;
end;

procedure TROJSONSerializer.WriteAnsiString(const aName: string; const Ref;
  ArrayElementId: integer);
var
  w: AnsiString absolute Ref;
begin
  IntWriteObject(aName, w);
end;

procedure TROJSONSerializer.WriteBinary(const aName: string; const Ref;
  ArrayElementId: integer);
var
  ss: TStringStream;
begin
  if Binary(Ref) <> nil then begin
    ss := TStringStream.Create('');
    try
      Binary(Ref).Position := 0;
      EncodeStream(Binary(Ref), ss);
      IntWriteObject(aName, ss.DataString);
    finally
      ss.Free;
    end;
  end;
end;

procedure TROJSONSerializer.WriteDateTime(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  IntWriteObject(aName, DateTimeToSOAPDateTime(TDateTime(Ref)));
end;

procedure TROJSONSerializer.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
  IntWriteObject(aName, s);
end;

procedure TROJSONSerializer.WriteDouble(const aName: string;
  aFloatType: TFloatType; const Ref; ArrayElementId: integer);
var
  text: string;
begin
  case aFloatType of
    ftSingle   : begin
      text := FloatToStr(single(Ref){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftDouble   : begin
      text := FloatToStr(double(Ref){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftExtended : begin
      text := FloatToStr(extended(Ref){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftComp     : begin
      text := FloatToStr(comp(Ref){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
    ftCurr     : begin
      text := FloatToStr(currency(Ref){$IFDEF DELPHI7UP},SOAPFormatSettings{$ENDIF});
      {$IFNDEF DELPHI7UP}text := StringReplace(text, DecimalSeparator, '.', []);{$ENDIF}
    end;
  end;
  IntWriteObject(aName, text);
end;

procedure TROJSONSerializer.WriteEnumerated(const aName: string;
  anEnumTypeInfo: PTypeInfo; const Ref; ArrayElementId: integer);
var
  val: string;
begin
  if (anEnumTypeInfo  = typeinfo(Boolean)) then
    IntWriteObject(aName, Boolean(Ref))
  else begin
    val := ROGetEnumName(anEnumTypeInfo, Ord(byte(Ref)));
    if (Length(val) > Length(anEnumTypeInfo.Name) + 2) and
       (Copy(val, 1, Length(anEnumTypeInfo.Name) + 1) = {$IFDEF UNICODE}UTF8ToString{$ENDIF}(anEnumTypeInfo.Name) + '_') then begin
      val := Copy(val, Length(anEnumTypeInfo.Name) + 2, MaxInt);
    end;
    IntWriteObject(aName, val);
  end;
end;

procedure TROJSONSerializer.WriteGuid(const aName: String; const Ref;
  ArrayElementId: Integer);
var
  s: string absolute Ref;
begin
  IntWriteObject(aName, s);
end;

procedure TROJSONSerializer.WriteInt64(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  IntWriteObject(aName, IntToStr(Int64(Ref)));
end;

procedure TROJSONSerializer.WriteInteger(const aName: string;
  anOrdType: TOrdType; const Ref; ArrayElementId: integer);
begin
  case anOrdType of
    otSByte: IntWriteObject(aName, IntToStr(ShortInt(Ref)));
    otUByte: IntWriteObject(aName, IntToStr(Byte(Ref)));
    otSWord: IntWriteObject(aName, IntToStr(SmallInt(Ref)));
    otUWord: IntWriteObject(aName, IntToStr(Word(Ref)));
    otSLong: IntWriteObject(aName, IntToStr(Integer(Ref)));
    otULong: IntWriteObject(aName, IntToStr(Cardinal(Ref)));
  end;
end;

procedure TROJSONSerializer.WriteUTF8String(const aName: string; const Ref;
  ArrayElementId: integer);
var
  w: WideString;
begin
  w := UTF8ToString(UTF8String(Ref));
  WriteWideString(aName, w);
end;

procedure TROJSONSerializer.WriteVariant(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  IntWriteObject(aName, Variant(Ref));
end;

procedure TROJSONSerializer.WriteWideString(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  IntWriteObject(aName, WideString(Ref));
end;

procedure TROJSONSerializer.WriteXml(const aName: string; const Ref;
  ArrayElementId: integer);
begin
  if IXMLNode(Ref) <> nil then begin
    IntWriteObject(aName, IXMLNode(Ref).XML);
  end;
end;

{ TROJSONMessage }


{ TROJSONMessage }

function TROJSONMessage.CreateSerializer: TROSerializer;
begin
  result := TROJSONSerializer.Create(self);
end;

procedure TROJSONMessage.ReadFromStream(aStream: TStream);
var
  obj: TROJSONValue;
  fId: string;
begin
  TROJSONSerializer(Serializer).fNested := False;
  FreeAndNil(fRoot);
  FRoot := TROJSONValue.Create(jdtObject);
  FRoot.LoadFromStream(aStream);
//  fCurrObject := FRoot.;
  obj := fRoot.AsObject.FindItem('id');
  if obj <> nil then begin
    fId := VarToStrDef(obj.VarValue, '');
    if (fSessionIdAsId) and (fId <> '') then
      ClientID := StringToGUID(fId);
    end;

  obj := froot.AsObject.FindItem('method');
  if obj <> Nil then begin
   fMessageType := mtRequest;
   InterfaceName := 'Default';
   fId := Obj.AsString;
    MessageName := fId;
    if (Pos('.', fId) <> 0) then begin
      InterfaceName := copy(fId, 1, pos('.', fId)-1);
      MessageName := Copy(fId, pos('.', fId)+1, MAxInt);
    end;
    FCurrObject := FRoot.AsObject.FindItem('params');
  end else begin
    obj := FRoot.AsObject.FindItem('error');
    if obj <> nil then begin
      fMessageType := mtException;
      fCurrObject := obj;
    end
    else begin
      obj := fRoot.AsObject.FindItem('result');
      if obj  = nil then begin
        raise EROJSONSerializerException.Create('Unknown Json payload');
      end;
      fCurrObject := obj;
      fMessageType := mtResponse;
   end;
  end;
end;

procedure TROJSONMessage.IntInitializeMessage;
begin
  TROJSONSerializer(Serializer).fNested := false;
  FreeAndNil(fRoot);
  FRoot := TROJSONValue.Create(jdtObject);
  FRoot.AsObject.AddStringProperty('version', '1.1');
  if fSessionIdAsId then begin
    fId := GUIDToString(ClientID);
    fRoot.AsObject.AddStringProperty('id', fId);
  end;
end;


procedure TROJSONMessage.Initialize(const aTransport: IROTransport;
  const anInterfaceName, aMessageName: string; aType: TMessageType);
var
  lMsgName: string;
begin
  fMessageType := aType;

  SetHTTPInfo(aTransport, DataFormatXml);
  if (anInterfaceName <> 'Default') and (anInterfaceName <> '') then
    lMsgName := anInterfaceName+'.'+aMessageName
  else
    lMsgName := aMessageName;

  IntInitializeMessage;
  fHaveResult := false;
  if fMessageType = mtException then
    // do nothing
  else if fMessageType = mtResponse then begin
    if fWrapResult then begin
      FCurrObject := FRoot.AsObject.AddObjectProperty('result');
    end else
      FCurrObject := nil;
  end else begin
    fRoot.AsObject.AddStringProperty('method',lMsgName);
    if fParamsAsArray then
      fCurrObject := FRoot.AsObject.AddArrayProperty('params')
    else
      FCurrObject := fRoot.AsObject.AddObjectProperty('params');
  end;
end;

procedure TROJSONMessage.InitializeExceptionMessage(
  const aTransport: IROTransport; const aLibraryName, anInterfaceName,
  aMessageName: String);
begin
  inherited;
  SetHTTPInfo(aTransport, DataFormatXml);
end;


function TROJSONMessage.ReadException: Exception;
begin
  if (FCurrObject = nil) or (FCurrObject.ValueType <> jdtObject) then
    result := EROServerException.Create('Unknown exception')
  else
    result := EROException.Create(FCurrObject.AsObject.GetStringValueByName('message'));
end;

function TROJSONMessage.IsValidMessage(aData: PAnsiChar;
  aLength: Integer): boolean;
var
  i: Integer;
begin
  for i := 0 to aLength -1 do begin
    if aData[i] = '{' then begin
     result := true;
     exit;
    end;
    case adata[i] of
      #32,
      #9,
      #13,
      #10: continue;
    else
      result := false;
      exit;
    end;
  end;
  result := false;
  exit;
end;

procedure TROJSONMessage.WriteException(aStream: TStream;
  anException: Exception);
var
  err: TROJSONValue;
begin
  IntInitializeMessage();

  err := FRoot.AsObject.AddObjectProperty('error');
  err.AsObject.AddStringProperty('name', 'JsonRPCError');
  err.AsObject.AddStringProperty('code', '1');
  err.AsObject.AddStringProperty('message', anException.Message);
  WriteToStream(aStream);
end;

procedure TROJSONMessage.WriteToStream(aStream: TStream);
begin
  if (fMessageType = mtResponse) and (not fWrapResult) and (not fHaveResult) then
    FRoot.AsObject.AddNullProperty('result');

  fRoot.SaveToStream(aStream);
end;

destructor TROJSONMessage.Destroy;
begin
  FRoot.Free;
  inherited;
end;

function TROJSONMessage.GetMessageType: TMessageType;
begin
  result := fMessageType;
end;

procedure TROJSONMessage.Assign(Source: TPersistent);
var src: TROJSONMessage;
begin
  inherited;
  if Source is TROJSONMessage then begin
     src := TROJSONMessage(Source);
     AddServerExceptionPrefix := src.AddServerExceptionPrefix;
     Indent := src.Indent;
     ParamsAsArray := src.ParamsAsArray;
     SessionIdAsId := src.SessionIdAsId;
     WrapResult := src.WrapResult;
  end;
end;

initialization
  {$IFDEF DELPHI7UP}
  GetLocaleFormatSettings(SOAPLocale,SOAPFormatSettings);
  //ToDo: fix this for D6
  {$ENDIF}
  RegisterMessageClass(TROJSONMessage);
end.