david
e4d0fcb01d
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@46 b6239004-a887-0f4b-9937-50029ccdca16
927 lines
30 KiB
ObjectPascal
927 lines
30 KiB
ObjectPascal
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. |