david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
1020 lines
33 KiB
ObjectPascal
1020 lines
33 KiB
ObjectPascal
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.
|
|
|