mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-28 22:20:25 +02:00
implemented endian independent object Text <-> Binary converter
git-svn-id: trunk@5794 -
This commit is contained in:
mattias
parent
4d1c380243
commit
50a941f84b
@ -493,7 +493,7 @@ begin
|
|||||||
BinCompStream.Position:=0;
|
BinCompStream.Position:=0;
|
||||||
// convert binary to text stream
|
// convert binary to text stream
|
||||||
try
|
try
|
||||||
ObjectBinaryToText(BinCompStream,TxtCompStream);
|
LRSObjectBinaryToText(BinCompStream,TxtCompStream);
|
||||||
except
|
except
|
||||||
on E: Exception do begin
|
on E: Exception do begin
|
||||||
MessageDlg(lisUnableConvertBinaryStreamToText,
|
MessageDlg(lisUnableConvertBinaryStreamToText,
|
||||||
|
|||||||
@ -3342,7 +3342,7 @@ begin
|
|||||||
+BufSize;
|
+BufSize;
|
||||||
try
|
try
|
||||||
BinCompStream.Position:=0;
|
BinCompStream.Position:=0;
|
||||||
ObjectBinaryToText(BinCompStream,TxtCompStream);
|
LRSObjectBinaryToText(BinCompStream,TxtCompStream);
|
||||||
AnUnitInfo.ComponentLastLFMStreamSize:=TxtCompStream.Size;
|
AnUnitInfo.ComponentLastLFMStreamSize:=TxtCompStream.Size;
|
||||||
// stream text to file
|
// stream text to file
|
||||||
TxtCompStream.Position:=0;
|
TxtCompStream.Position:=0;
|
||||||
@ -3784,7 +3784,7 @@ begin
|
|||||||
try
|
try
|
||||||
if AnUnitInfo.ComponentLastBinStreamSize>0 then
|
if AnUnitInfo.ComponentLastBinStreamSize>0 then
|
||||||
BinLFMStream.Capacity:=AnUnitInfo.ComponentLastBinStreamSize+BufSize;
|
BinLFMStream.Capacity:=AnUnitInfo.ComponentLastBinStreamSize+BufSize;
|
||||||
ObjectTextToBinary(TxtLFMStream,BinLFMStream);
|
LRSObjectTextToBinary(TxtLFMStream,BinLFMStream);
|
||||||
AnUnitInfo.ComponentLastBinStreamSize:=BinLFMStream.Size;
|
AnUnitInfo.ComponentLastBinStreamSize:=BinLFMStream.Size;
|
||||||
BinLFMStream.Position:=0;
|
BinLFMStream.Position:=0;
|
||||||
Result:=mrOk;
|
Result:=mrOk;
|
||||||
@ -8264,7 +8264,7 @@ begin
|
|||||||
BinCompStream:=TMemoryStream.Create;
|
BinCompStream:=TMemoryStream.Create;
|
||||||
try
|
try
|
||||||
try
|
try
|
||||||
ObjectTextToBinary(TxtCompStream,BinCompStream);
|
LRSObjectTextToBinary(TxtCompStream,BinCompStream);
|
||||||
except
|
except
|
||||||
on E: Exception do begin
|
on E: Exception do begin
|
||||||
MessageDlg(lisConversionError,
|
MessageDlg(lisConversionError,
|
||||||
@ -10582,6 +10582,9 @@ end.
|
|||||||
|
|
||||||
{ =============================================================================
|
{ =============================================================================
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.754 2004/08/15 17:53:32 mattias
|
||||||
|
implemented endian independent object Text <-> Binary converter
|
||||||
|
|
||||||
Revision 1.753 2004/08/15 14:39:36 mattias
|
Revision 1.753 2004/08/15 14:39:36 mattias
|
||||||
implemented platform independent binary object streamer
|
implemented platform independent binary object streamer
|
||||||
|
|
||||||
|
|||||||
@ -195,6 +195,7 @@ type
|
|||||||
TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
|
TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
|
||||||
|
|
||||||
procedure LRSObjectBinaryToText(Input, Output: TStream);
|
procedure LRSObjectBinaryToText(Input, Output: TStream);
|
||||||
|
procedure LRSObjectTextToBinary(Input, Output: TStream);
|
||||||
procedure LRSObjectToText(Input, Output: TStream;
|
procedure LRSObjectToText(Input, Output: TStream;
|
||||||
var OriginalFormat: TLRSStreamOriginalFormat);
|
var OriginalFormat: TLRSStreamOriginalFormat);
|
||||||
|
|
||||||
@ -530,7 +531,7 @@ begin
|
|||||||
FormClassName:=FindLFMClassName(LFMStream);
|
FormClassName:=FindLFMClassName(LFMStream);
|
||||||
BinStream:=TMemoryStream.Create;
|
BinStream:=TMemoryStream.Create;
|
||||||
try
|
try
|
||||||
ObjectTextToBinary(LFMStream,BinStream);
|
LRSObjectTextToBinary(LFMStream,BinStream);
|
||||||
BinStream.Position:=0;
|
BinStream.Position:=0;
|
||||||
BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName
|
BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName
|
||||||
,'FORMDATA');
|
,'FORMDATA');
|
||||||
@ -1142,7 +1143,7 @@ begin
|
|||||||
try
|
try
|
||||||
// transform binary to text
|
// transform binary to text
|
||||||
BinStream.Position:=0;
|
BinStream.Position:=0;
|
||||||
ObjectBinaryToText(BinStream,LFMStream);
|
LRSObjectBinaryToText(BinStream,LFMStream);
|
||||||
except
|
except
|
||||||
Result:=-2;
|
Result:=-2;
|
||||||
exit;
|
exit;
|
||||||
@ -1153,338 +1154,278 @@ begin
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
procedure LRSObjectBinaryToText(Input, Output: TStream);
|
procedure LRSObjectBinaryToText(Input, Output: TStream);
|
||||||
var
|
|
||||||
NestingLevel: Integer;
|
|
||||||
SaveSeparator: Char;
|
|
||||||
Reader: TDelphiReader;
|
|
||||||
Writer: TDelphiWriter;
|
|
||||||
ObjectName, PropName: string;
|
|
||||||
|
|
||||||
procedure WriteIndent;
|
procedure OutStr(const s: String);
|
||||||
const
|
|
||||||
Blanks: array[0..1] of Char = ' ';
|
|
||||||
var
|
var
|
||||||
I: Integer;
|
i: Integer;
|
||||||
begin
|
begin
|
||||||
for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
|
for i:=1 to length(s) do begin
|
||||||
end;
|
if (s[i] in [#0..#8,#11..#12,#14..#31]) then begin
|
||||||
|
DbgOut('#'+IntToStr(ord(s[i])));
|
||||||
procedure WriteStr(const S: string);
|
RaiseGDBException('ObjectLRSToText: Invalid character');
|
||||||
begin
|
end else
|
||||||
Writer.Write(S[1], Length(S));
|
DbgOut(s[i]);
|
||||||
end;
|
|
||||||
|
|
||||||
procedure NewLine;
|
|
||||||
begin
|
|
||||||
WriteStr(LineEnd);
|
|
||||||
WriteIndent;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure ConvertValue; forward;
|
|
||||||
|
|
||||||
procedure ConvertHeader;
|
|
||||||
var
|
|
||||||
ClassName: string;
|
|
||||||
Flags: TFilerFlags;
|
|
||||||
Position: Integer;
|
|
||||||
begin
|
|
||||||
Reader.ReadPrefix(Flags, Position);
|
|
||||||
ClassName := Reader.ReadStr;
|
|
||||||
ObjectName := Reader.ReadStr;
|
|
||||||
WriteIndent;
|
|
||||||
if ffInherited in Flags then
|
|
||||||
WriteStr('inherited ')
|
|
||||||
else if ffInline in Flags then
|
|
||||||
WriteStr('inline ')
|
|
||||||
else
|
|
||||||
WriteStr('object ');
|
|
||||||
if ObjectName <> '' then
|
|
||||||
begin
|
|
||||||
WriteStr(ObjectName);
|
|
||||||
WriteStr(': ');
|
|
||||||
end;
|
end;
|
||||||
WriteStr(ClassName);
|
if Length(s) > 0 then
|
||||||
if ffChildPos in Flags then
|
Output.Write(s[1], Length(s));
|
||||||
begin
|
|
||||||
WriteStr(' [');
|
|
||||||
WriteStr(IntToStr(Position));
|
|
||||||
WriteStr(']');
|
|
||||||
end;
|
|
||||||
|
|
||||||
if ObjectName = '' then
|
|
||||||
ObjectName := ClassName; // save for error reporting
|
|
||||||
|
|
||||||
WriteStr(LineEnd);
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
|
procedure OutLn(const s: String);
|
||||||
const
|
|
||||||
Convert: array[0..15] of Char = '0123456789ABCDEF';
|
|
||||||
var
|
|
||||||
I: Integer;
|
|
||||||
begin
|
begin
|
||||||
for I := 0 to BufSize - 1 do
|
OutStr(s + #13#10);
|
||||||
begin
|
|
||||||
Text[0] := Convert[Byte(Buffer[I]) shr 4];
|
|
||||||
Text[1] := Convert[Byte(Buffer[I]) and $F];
|
|
||||||
Inc(Text, 2);
|
|
||||||
end;
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure ConvertBinary;
|
procedure OutString(const s: String);
|
||||||
const
|
|
||||||
BytesPerLine = 32;
|
|
||||||
var
|
var
|
||||||
MultiLine: Boolean;
|
res, NewStr: String;
|
||||||
I: Integer;
|
i: Integer;
|
||||||
Count: Longint;
|
InString, NewInString: Boolean;
|
||||||
Buffer: array[0..BytesPerLine - 1] of Char;
|
|
||||||
Text: array[0..BytesPerLine * 2 - 1] of Char;
|
|
||||||
begin
|
begin
|
||||||
Reader.ReadValue;
|
res := '';
|
||||||
WriteStr('{');
|
InString := False;
|
||||||
Inc(NestingLevel);
|
for i := 1 to Length(s) do begin
|
||||||
Reader.Read(Count, SizeOf(Count));
|
NewInString := InString;
|
||||||
MultiLine := Count >= BytesPerLine;
|
case s[i] of
|
||||||
while Count > 0 do
|
#0..#31: begin
|
||||||
begin
|
if InString then
|
||||||
if MultiLine then NewLine;
|
NewInString := False;
|
||||||
if Count >= 32 then I := 32 else I := Count;
|
NewStr := '#' + IntToStr(Ord(s[i]));
|
||||||
Reader.Read(Buffer, I);
|
|
||||||
BinToHex(Buffer, Text, I);
|
|
||||||
Writer.Write(Text, I * 2);
|
|
||||||
Dec(Count, I);
|
|
||||||
end;
|
|
||||||
Dec(NestingLevel);
|
|
||||||
WriteStr('}');
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure ConvertProperty; forward;
|
|
||||||
|
|
||||||
procedure ConvertValue;
|
|
||||||
const
|
|
||||||
LineLength = 64;
|
|
||||||
var
|
|
||||||
I, J, K, L: Integer;
|
|
||||||
S: string;
|
|
||||||
//W: WideString;
|
|
||||||
LineBreak: Boolean;
|
|
||||||
begin
|
|
||||||
case Reader.NextValue of
|
|
||||||
dvaList:
|
|
||||||
begin
|
|
||||||
Reader.ReadValue;
|
|
||||||
WriteStr('(');
|
|
||||||
Inc(NestingLevel);
|
|
||||||
while not Reader.EndOfList do
|
|
||||||
begin
|
|
||||||
NewLine;
|
|
||||||
ConvertValue;
|
|
||||||
end;
|
end;
|
||||||
Reader.ReadListEnd;
|
'''':
|
||||||
Dec(NestingLevel);
|
if InString then NewStr := ''''''
|
||||||
WriteStr(')');
|
else NewStr := '''''''';
|
||||||
|
else begin
|
||||||
|
if not InString then
|
||||||
|
NewInString := True;
|
||||||
|
NewStr := s[i];
|
||||||
end;
|
end;
|
||||||
dvaInt8, dvaInt16, dvaInt32:
|
end;
|
||||||
WriteStr(IntToStr(Reader.ReadInteger));
|
if NewInString <> InString then begin
|
||||||
dvaExtended:
|
NewStr := '''' + NewStr;
|
||||||
WriteStr(FloatToStr(Reader.ReadFloat));
|
InString := NewInString;
|
||||||
dvaSingle:
|
end;
|
||||||
WriteStr(FloatToStr(Reader.ReadSingle) + 's');
|
res := res + NewStr;
|
||||||
dvaCurrency:
|
end;
|
||||||
WriteStr(FloatToStr(Reader.ReadCurrency * 10000) + 'c');
|
if InString then res := res + '''';
|
||||||
dvaDate:
|
OutStr(res);
|
||||||
WriteStr(FloatToStr(Reader.ReadDate) + 'd');
|
end;
|
||||||
dvaWString, dvaUTF8String:
|
|
||||||
begin
|
function ReadInt(ValueType: TValueType): LongInt;
|
||||||
ReadError('TDelphiReader: not implemented yet: wide/utf8 string support');
|
var
|
||||||
{W := Reader.ReadWideString;
|
w: Word;
|
||||||
ToDo: L := Length(W);
|
begin
|
||||||
if L = 0 then WriteStr('''''') else
|
case ValueType of
|
||||||
begin
|
vaInt8: Result := ShortInt(Input.ReadByte);
|
||||||
I := 1;
|
vaInt16: begin
|
||||||
Inc(NestingLevel);
|
w:=ReadLRSWord(Input);
|
||||||
try
|
writeln('ReadInt vaInt16 w=',w);
|
||||||
if L > LineLength then NewLine;
|
Result := SmallInt(ReadLRSWord(Input));
|
||||||
K := I;
|
end;
|
||||||
repeat
|
vaInt32: Result := ReadLRSInteger(Input);
|
||||||
LineBreak := False;
|
end;
|
||||||
if (W[I] >= ' ') and (W[I] <> '''') and (Ord(W[i]) <= 127) then
|
end;
|
||||||
begin
|
|
||||||
J := I;
|
function ReadInt: LongInt;
|
||||||
repeat
|
begin
|
||||||
Inc(I)
|
Result := ReadInt(TValueType(Input.ReadByte));
|
||||||
until (I > L) or (W[I] < ' ') or (W[I] = '''') or
|
end;
|
||||||
((I - K) >= LineLength) or (Ord(W[i]) > 127);
|
|
||||||
if ((I - K) >= LineLength) then LineBreak := True;
|
function ReadShortString: String;
|
||||||
WriteStr('''');
|
var
|
||||||
while J < I do
|
len: Byte;
|
||||||
begin
|
begin
|
||||||
WriteStr(Char(W[J]));
|
len := Input.ReadByte;
|
||||||
Inc(J);
|
SetLength(Result, len);
|
||||||
end;
|
Input.Read(Result[1], len);
|
||||||
WriteStr('''');
|
end;
|
||||||
end else
|
|
||||||
begin
|
function ReadLongString: String;
|
||||||
WriteStr('#');
|
var
|
||||||
WriteStr(IntToStr(Ord(W[I])));
|
len: integer;
|
||||||
Inc(I);
|
begin
|
||||||
if ((I - K) >= LineLength) then LineBreak := True;
|
len := ReadLRSInteger(Input);
|
||||||
end;
|
SetLength(Result, len);
|
||||||
if LineBreak and (I <= L) then
|
Input.Read(Result[1], len);
|
||||||
begin
|
end;
|
||||||
WriteStr(' +');
|
|
||||||
NewLine;
|
procedure ReadPropList(const indent: String);
|
||||||
K := I;
|
|
||||||
end;
|
procedure ProcessValue(ValueType: TValueType; const Indent: String);
|
||||||
until I > L;
|
|
||||||
finally
|
procedure Stop(const s: String);
|
||||||
Dec(NestingLevel);
|
begin
|
||||||
|
RaiseGDBException('ObjectLRSToText Unimplemented '+s);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ProcessBinary;
|
||||||
|
var
|
||||||
|
ToDo, DoNow, i: LongInt;
|
||||||
|
lbuf: array[0..31] of Byte;
|
||||||
|
s: String;
|
||||||
|
begin
|
||||||
|
ToDo := Input.ReadDWord;
|
||||||
|
OutLn('{');
|
||||||
|
while ToDo > 0 do begin
|
||||||
|
DoNow := ToDo;
|
||||||
|
if DoNow > 32 then DoNow := 32;
|
||||||
|
Dec(ToDo, DoNow);
|
||||||
|
s := Indent + ' ';
|
||||||
|
Input.Read(lbuf, DoNow);
|
||||||
|
for i := 0 to DoNow - 1 do
|
||||||
|
s := s + IntToHex(lbuf[i], 2);
|
||||||
|
OutLn(s);
|
||||||
|
end;
|
||||||
|
OutStr(indent);
|
||||||
|
OutLn('}');
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
s: String;
|
||||||
|
IsFirst: Boolean;
|
||||||
|
ext: Extended;
|
||||||
|
ASingle: single;
|
||||||
|
ADate: TDateTime;
|
||||||
|
ACurrency: Currency;
|
||||||
|
AWideString: WideString;
|
||||||
|
|
||||||
|
begin
|
||||||
|
case ValueType of
|
||||||
|
vaList: begin
|
||||||
|
OutStr('(');
|
||||||
|
IsFirst := True;
|
||||||
|
while True do begin
|
||||||
|
ValueType := TValueType(Input.ReadByte);
|
||||||
|
if ValueType = vaNull then break;
|
||||||
|
if IsFirst then begin
|
||||||
|
OutLn('');
|
||||||
|
IsFirst := False;
|
||||||
|
end;
|
||||||
|
OutStr(Indent + ' ');
|
||||||
|
ProcessValue(ValueType, Indent + ' ');
|
||||||
end;
|
end;
|
||||||
end;}
|
OutLn(Indent + ')');
|
||||||
end;
|
end;
|
||||||
dvaString, dvaLString:
|
vaInt8: OutLn(IntToStr(ShortInt(Input.ReadByte)));
|
||||||
begin
|
vaInt16: OutLn(IntToStr(SmallInt(ReadLRSWord(Input))));
|
||||||
S := Reader.ReadString;
|
vaInt32: OutLn(IntToStr(ReadLRSInteger(Input)));
|
||||||
L := Length(S);
|
vaInt64: OutLn(IntToStr(ReadLRSInt64(Input)));
|
||||||
if L = 0 then WriteStr('''''') else
|
vaExtended: begin
|
||||||
begin
|
ext:=ReadLRSExtended(Input);
|
||||||
I := 1;
|
OutLn(FloatToStr(ext));
|
||||||
Inc(NestingLevel);
|
end;
|
||||||
try
|
vaString: begin
|
||||||
if L > LineLength then NewLine;
|
OutString(ReadShortString);
|
||||||
K := I;
|
OutLn('');
|
||||||
repeat
|
end;
|
||||||
LineBreak := False;
|
vaIdent: OutLn(ReadShortString);
|
||||||
if (S[I] >= ' ') and (S[I] <> '''') then
|
vaFalse: OutLn('False');
|
||||||
begin
|
vaTrue: OutLn('True');
|
||||||
J := I;
|
vaBinary: ProcessBinary;
|
||||||
repeat
|
vaSet: begin
|
||||||
Inc(I)
|
OutStr('[');
|
||||||
until (I > L) or (S[I] < ' ') or (S[I] = '''') or
|
IsFirst := True;
|
||||||
((I - K) >= LineLength);
|
while True do begin
|
||||||
if ((I - K) >= LineLength) then
|
s := ReadShortString;
|
||||||
begin
|
if Length(s) = 0 then break;
|
||||||
LineBreak := True;
|
if not IsFirst then OutStr(', ');
|
||||||
if ByteType(S, I) = mbTrailByte then Dec(I);
|
IsFirst := False;
|
||||||
end;
|
OutStr(s);
|
||||||
WriteStr('''');
|
|
||||||
Writer.Write(S[J], I - J);
|
|
||||||
WriteStr('''');
|
|
||||||
end else
|
|
||||||
begin
|
|
||||||
WriteStr('#');
|
|
||||||
WriteStr(IntToStr(Ord(S[I])));
|
|
||||||
Inc(I);
|
|
||||||
if ((I - K) >= LineLength) then LineBreak := True;
|
|
||||||
end;
|
|
||||||
if LineBreak and (I <= L) then
|
|
||||||
begin
|
|
||||||
WriteStr(' +');
|
|
||||||
NewLine;
|
|
||||||
K := I;
|
|
||||||
end;
|
|
||||||
until I > L;
|
|
||||||
finally
|
|
||||||
Dec(NestingLevel);
|
|
||||||
end;
|
end;
|
||||||
|
OutLn(']');
|
||||||
end;
|
end;
|
||||||
end;
|
vaLString: begin
|
||||||
dvaIdent, dvaFalse, dvaTrue, dvaNil, dvaNull:
|
OutString(ReadLongString);
|
||||||
WriteStr(Reader.ReadIdent);
|
OutLn('');
|
||||||
dvaBinary:
|
|
||||||
ConvertBinary;
|
|
||||||
dvaSet:
|
|
||||||
begin
|
|
||||||
Reader.ReadValue;
|
|
||||||
WriteStr('[');
|
|
||||||
I := 0;
|
|
||||||
while True do
|
|
||||||
begin
|
|
||||||
S := Reader.ReadStr;
|
|
||||||
if S = '' then Break;
|
|
||||||
if I > 0 then WriteStr(', ');
|
|
||||||
WriteStr(S);
|
|
||||||
Inc(I);
|
|
||||||
end;
|
end;
|
||||||
WriteStr(']');
|
vaNil:
|
||||||
end;
|
OutLn('nil');
|
||||||
dvaCollection:
|
vaCollection: begin
|
||||||
begin
|
OutStr('<');
|
||||||
Reader.ReadValue;
|
while Input.ReadByte <> 0 do begin
|
||||||
WriteStr('<');
|
OutLn(Indent);
|
||||||
Inc(NestingLevel);
|
Input.Seek(-1, soFromCurrent);
|
||||||
while not Reader.EndOfList do
|
OutStr(indent + ' item');
|
||||||
begin
|
ValueType := TValueType(Input.ReadByte);
|
||||||
NewLine;
|
if ValueType <> vaList then
|
||||||
WriteStr('item');
|
OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
|
||||||
if Reader.NextValue in [dvaInt8, dvaInt16, dvaInt32] then
|
OutLn('');
|
||||||
begin
|
ReadPropList(indent + ' ');
|
||||||
WriteStr(' [');
|
OutStr(indent + ' end');
|
||||||
ConvertValue;
|
|
||||||
WriteStr(']');
|
|
||||||
end;
|
end;
|
||||||
WriteStr(LineEnd);
|
OutLn('>');
|
||||||
Reader.CheckValue(dvaList);
|
|
||||||
Inc(NestingLevel);
|
|
||||||
while not Reader.EndOfList do ConvertProperty;
|
|
||||||
Reader.ReadListEnd;
|
|
||||||
Dec(NestingLevel);
|
|
||||||
WriteIndent;
|
|
||||||
WriteStr('end');
|
|
||||||
end;
|
end;
|
||||||
Reader.ReadListEnd;
|
vaSingle: begin
|
||||||
Dec(NestingLevel);
|
ASingle:=ReadLRSSingle(Input);
|
||||||
WriteStr('>');
|
OutLn(FloatToStr(ASingle));
|
||||||
|
end;
|
||||||
|
vaDate: begin
|
||||||
|
ADate:=TDateTime(ReadLRSDouble(Input));
|
||||||
|
OutLn(FloatToStr(ADate));
|
||||||
|
end;
|
||||||
|
vaCurrency: begin
|
||||||
|
ACurrency:=ReadLRSCurrency(Input);
|
||||||
|
OutLn(FloatToStr(ACurrency));
|
||||||
|
end;
|
||||||
|
vaWString: begin
|
||||||
|
AWideString:=ReadLRSWideString(Input);
|
||||||
|
OutLn(AWideString);
|
||||||
|
end;
|
||||||
|
else begin
|
||||||
|
debugln('Unknown ValueType=',dbgs(Ord(ValueType)),' vaInt16=',dbgs(Ord(vaInt16)));
|
||||||
|
Stop(IntToStr(Ord(ValueType)));
|
||||||
end;
|
end;
|
||||||
dvaInt64:
|
end;
|
||||||
WriteStr(IntToStr(Reader.ReadInt64));
|
end;
|
||||||
else
|
|
||||||
ReadError(Format(rsErrorReadingProperty,
|
begin
|
||||||
[ObjectName, '.', PropName, Ord(Reader.NextValue)]));
|
while Input.ReadByte <> 0 do begin
|
||||||
|
Input.Seek(-1, soFromCurrent);
|
||||||
|
OutStr(indent + ReadShortString + ' = ');
|
||||||
|
ProcessValue(TValueType(Input.ReadByte), Indent);
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure ConvertProperty;
|
procedure ReadObject(const indent: String);
|
||||||
|
var
|
||||||
|
b: Byte;
|
||||||
|
ObjClassName, ObjName: String;
|
||||||
|
ChildPos: LongInt;
|
||||||
begin
|
begin
|
||||||
WriteIndent;
|
// Check for FilerFlags
|
||||||
PropName := Reader.ReadStr; // save for error reporting
|
b := Input.ReadByte;
|
||||||
WriteStr(PropName);
|
if (b and $f0) = $f0 then begin
|
||||||
WriteStr(' = ');
|
if (b and 2) <> 0 then ChildPos := ReadInt;
|
||||||
ConvertValue;
|
end else begin
|
||||||
WriteStr(LineEnd);
|
b := 0;
|
||||||
end;
|
Input.Seek(-1, soFromCurrent);
|
||||||
|
end;
|
||||||
|
|
||||||
procedure ConvertObject;
|
ObjClassName := ReadShortString;
|
||||||
begin
|
ObjName := ReadShortString;
|
||||||
ConvertHeader;
|
|
||||||
Inc(NestingLevel);
|
OutStr(Indent);
|
||||||
while not Reader.EndOfList do ConvertProperty;
|
if (b and 1) <> 0 then OutStr('inherited')
|
||||||
Reader.ReadListEnd;
|
else OutStr('object');
|
||||||
while not Reader.EndOfList do ConvertObject;
|
OutStr(' ');
|
||||||
Reader.ReadListEnd;
|
if ObjName <> '' then
|
||||||
Dec(NestingLevel);
|
OutStr(ObjName + ': ');
|
||||||
WriteIndent;
|
OutStr(ObjClassName);
|
||||||
WriteStr('end' + LineEnd);
|
if (b and 2) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
|
||||||
|
OutLn('');
|
||||||
|
|
||||||
|
ReadPropList(indent + ' ');
|
||||||
|
|
||||||
|
while Input.ReadByte <> 0 do begin
|
||||||
|
Input.Seek(-1, soFromCurrent);
|
||||||
|
ReadObject(indent + ' ');
|
||||||
|
end;
|
||||||
|
OutLn(indent + 'end');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
NestingLevel := 0;
|
if Input.ReadDWord <> PLongWord(@FilerSignature[1])^ then
|
||||||
Reader := TDelphiReader.Create(Input);
|
raise EReadError.Create('Illegal stream image' {###SInvalidImage});
|
||||||
SaveSeparator := DecimalSeparator;
|
ReadObject('');
|
||||||
DecimalSeparator := '.';
|
|
||||||
try
|
|
||||||
Writer := TDelphiWriter.Create(Output);
|
|
||||||
try
|
|
||||||
Reader.ReadSignature;
|
|
||||||
ConvertObject;
|
|
||||||
finally
|
|
||||||
Writer.Free;
|
|
||||||
end;
|
|
||||||
finally
|
|
||||||
DecimalSeparator := SaveSeparator;
|
|
||||||
Reader.Free;
|
|
||||||
end;
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
|
function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
|
||||||
@ -1555,6 +1496,252 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure LRSObjectTextToBinary(Input, Output: TStream);
|
||||||
|
var
|
||||||
|
parser: TParser;
|
||||||
|
|
||||||
|
procedure WriteShortString(const s: String);
|
||||||
|
var
|
||||||
|
Size: Integer;
|
||||||
|
begin
|
||||||
|
Size:=length(s);
|
||||||
|
if Size>255 then Size:=255;
|
||||||
|
Output.WriteByte(byte(Size));
|
||||||
|
if Size > 0 then
|
||||||
|
Output.Write(s[1], Size);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteLongString(const s: String);
|
||||||
|
begin
|
||||||
|
WriteLRSInteger(Output,Length(s));
|
||||||
|
if Length(s) > 0 then
|
||||||
|
Output.Write(s[1], Length(s));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteInteger(value: LongInt);
|
||||||
|
begin
|
||||||
|
if (value >= -128) and (value <= 127) then begin
|
||||||
|
Output.WriteByte(Ord(vaInt8));
|
||||||
|
Output.WriteByte(Byte(value));
|
||||||
|
end else if (value >= -32768) and (value <= 32767) then begin
|
||||||
|
Output.WriteByte(Ord(vaInt16));
|
||||||
|
WriteLRSWord(Output,Word(value));
|
||||||
|
end else begin
|
||||||
|
Output.WriteByte(ord(vaInt32));
|
||||||
|
WriteLRSInteger(Output,value);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteInt64(const Value: Int64);
|
||||||
|
begin
|
||||||
|
if (Value >= -$80000000) and (Value <= $7fffffff) then
|
||||||
|
WriteInteger(Integer(Value))
|
||||||
|
else begin
|
||||||
|
Output.WriteByte(ord(vaInt64));
|
||||||
|
WriteLRSInt64(Output,Value);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure WriteIntegerStr(const s: string);
|
||||||
|
begin
|
||||||
|
if length(s)>7 then
|
||||||
|
WriteInt64(StrToInt64(s))
|
||||||
|
else
|
||||||
|
WriteInteger(StrToInt(s));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ProcessProperty; forward;
|
||||||
|
|
||||||
|
procedure ProcessValue;
|
||||||
|
var
|
||||||
|
flt: Extended;
|
||||||
|
s: String;
|
||||||
|
stream: TMemoryStream;
|
||||||
|
BinDataSize: LongInt;
|
||||||
|
begin
|
||||||
|
case parser.Token of
|
||||||
|
toInteger:
|
||||||
|
begin
|
||||||
|
WriteIntegerStr(parser.TokenString);
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
toFloat:
|
||||||
|
begin
|
||||||
|
Output.WriteByte(Ord(vaExtended));
|
||||||
|
flt := Parser.TokenFloat;
|
||||||
|
WriteLRSExtended(Output,flt);
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
toString:
|
||||||
|
begin
|
||||||
|
s := parser.TokenString;
|
||||||
|
while parser.NextToken = '+' do
|
||||||
|
begin
|
||||||
|
parser.NextToken; // Get next string fragment
|
||||||
|
parser.CheckToken(toString);
|
||||||
|
s := s + parser.TokenString;
|
||||||
|
end;
|
||||||
|
if length(s)<256 then begin
|
||||||
|
Output.WriteByte(Ord(vaString));
|
||||||
|
WriteShortString(s);
|
||||||
|
end else begin
|
||||||
|
Output.WriteByte(Ord(vaLString));
|
||||||
|
WriteLongString(s);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
toSymbol:
|
||||||
|
begin
|
||||||
|
if CompareText(parser.TokenString, 'True') = 0 then
|
||||||
|
Output.WriteByte(Ord(vaTrue))
|
||||||
|
else if CompareText(parser.TokenString, 'False') = 0 then
|
||||||
|
Output.WriteByte(Ord(vaFalse))
|
||||||
|
else if CompareText(parser.TokenString, 'nil') = 0 then
|
||||||
|
Output.WriteByte(Ord(vaNil))
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
Output.WriteByte(Ord(vaIdent));
|
||||||
|
WriteShortString(parser.TokenComponentIdent);
|
||||||
|
end;
|
||||||
|
Parser.NextToken;
|
||||||
|
end;
|
||||||
|
// Set
|
||||||
|
'[':
|
||||||
|
begin
|
||||||
|
parser.NextToken;
|
||||||
|
Output.WriteByte(Ord(vaSet));
|
||||||
|
if parser.Token <> ']' then
|
||||||
|
while True do
|
||||||
|
begin
|
||||||
|
parser.CheckToken(toSymbol);
|
||||||
|
WriteShortString(parser.TokenString);
|
||||||
|
parser.NextToken;
|
||||||
|
if parser.Token = ']' then
|
||||||
|
break;
|
||||||
|
parser.CheckToken(',');
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
Output.WriteByte(0);
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
// List
|
||||||
|
'(':
|
||||||
|
begin
|
||||||
|
parser.NextToken;
|
||||||
|
Output.WriteByte(Ord(vaList));
|
||||||
|
while parser.Token <> ')' do
|
||||||
|
ProcessValue;
|
||||||
|
Output.WriteByte(0);
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
// Collection
|
||||||
|
'<':
|
||||||
|
begin
|
||||||
|
parser.NextToken;
|
||||||
|
Output.WriteByte(Ord(vaCollection));
|
||||||
|
while parser.Token <> '>' do
|
||||||
|
begin
|
||||||
|
parser.CheckTokenSymbol('item');
|
||||||
|
parser.NextToken;
|
||||||
|
// ConvertOrder
|
||||||
|
Output.WriteByte(Ord(vaList));
|
||||||
|
while not parser.TokenSymbolIs('end') do
|
||||||
|
ProcessProperty;
|
||||||
|
parser.NextToken; // Skip 'end'
|
||||||
|
Output.WriteByte(0);
|
||||||
|
end;
|
||||||
|
Output.WriteByte(0);
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
// Binary data
|
||||||
|
'{':
|
||||||
|
begin
|
||||||
|
Output.WriteByte(Ord(vaBinary));
|
||||||
|
stream := TMemoryStream.Create;
|
||||||
|
try
|
||||||
|
parser.HexToBinary(stream);
|
||||||
|
BinDataSize:=integer(stream.Size);
|
||||||
|
WriteLRSInteger(Output,BinDataSize);
|
||||||
|
Output.Write(Stream.Memory^, BinDataSize);
|
||||||
|
finally
|
||||||
|
stream.Free;
|
||||||
|
end;
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
else
|
||||||
|
parser.Error(SInvalidProperty);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ProcessProperty;
|
||||||
|
var
|
||||||
|
name: String;
|
||||||
|
begin
|
||||||
|
// Get name of property
|
||||||
|
parser.CheckToken(toSymbol);
|
||||||
|
name := parser.TokenString;
|
||||||
|
while True do begin
|
||||||
|
parser.NextToken;
|
||||||
|
if parser.Token <> '.' then break;
|
||||||
|
parser.NextToken;
|
||||||
|
parser.CheckToken(toSymbol);
|
||||||
|
name := name + '.' + parser.TokenString;
|
||||||
|
end;
|
||||||
|
WriteShortString(name);
|
||||||
|
parser.CheckToken('=');
|
||||||
|
parser.NextToken;
|
||||||
|
ProcessValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ProcessObject;
|
||||||
|
var
|
||||||
|
IsInherited: Boolean;
|
||||||
|
ObjectName, ObjectType: String;
|
||||||
|
begin
|
||||||
|
if parser.TokenSymbolIs('OBJECT') then
|
||||||
|
IsInherited := False
|
||||||
|
else begin
|
||||||
|
parser.CheckTokenSymbol('INHERITED');
|
||||||
|
IsInherited := True;
|
||||||
|
end;
|
||||||
|
if IsInherited then ;
|
||||||
|
parser.NextToken;
|
||||||
|
parser.CheckToken(toSymbol);
|
||||||
|
ObjectName := '';
|
||||||
|
ObjectType := parser.TokenString;
|
||||||
|
parser.NextToken;
|
||||||
|
if parser.Token = ':' then begin
|
||||||
|
parser.NextToken;
|
||||||
|
parser.CheckToken(toSymbol);
|
||||||
|
ObjectName := ObjectType;
|
||||||
|
ObjectType := parser.TokenString;
|
||||||
|
parser.NextToken;
|
||||||
|
end;
|
||||||
|
WriteShortString(ObjectType);
|
||||||
|
WriteShortString(ObjectName);
|
||||||
|
|
||||||
|
// Convert property list
|
||||||
|
while not (parser.TokenSymbolIs('END') or
|
||||||
|
parser.TokenSymbolIs('OBJECT') or
|
||||||
|
parser.TokenSymbolIs('INHERITED')) do
|
||||||
|
ProcessProperty;
|
||||||
|
Output.WriteByte(0); // Terminate property list
|
||||||
|
|
||||||
|
// Convert child objects
|
||||||
|
while not parser.TokenSymbolIs('END') do ProcessObject;
|
||||||
|
parser.NextToken; // Skip end token
|
||||||
|
Output.WriteByte(0); // Terminate property list
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
parser := TParser.Create(Input);
|
||||||
|
try
|
||||||
|
Output.Write(FilerSignature, SizeOf(FilerSignature));
|
||||||
|
ProcessObject;
|
||||||
|
finally
|
||||||
|
parser.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
procedure LRSObjectToText(Input, Output: TStream;
|
procedure LRSObjectToText(Input, Output: TStream;
|
||||||
var OriginalFormat: TLRSStreamOriginalFormat);
|
var OriginalFormat: TLRSStreamOriginalFormat);
|
||||||
begin
|
begin
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user