mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-05 13:37:47 +02:00
* Add ObjectTextToBinary and TParser
This commit is contained in:
michael
parent
0d92a818eb
commit
0b21ea3b26
@ -1212,6 +1212,85 @@ type
|
||||
property PropertyPath: string read FPropPath;
|
||||
end;
|
||||
|
||||
TParserToken = (toUnknown, // everything else
|
||||
toEOF, // EOF
|
||||
toSymbol, // Symbol (identifier)
|
||||
toString, // ''string''
|
||||
toInteger, // 123
|
||||
toFloat, // 12.3
|
||||
toMinus, // -
|
||||
toSetStart, // [
|
||||
toListStart, // (
|
||||
toCollectionStart, // <
|
||||
toBinaryStart, // {
|
||||
toSetEnd, // ]
|
||||
toListEnd, // )
|
||||
toCollectionEnd, // >
|
||||
toBinaryEnd, // }
|
||||
toComma, // ,
|
||||
toDot, // .
|
||||
toEqual, // =
|
||||
toColon // :
|
||||
);
|
||||
|
||||
TParser = class(TObject)
|
||||
private
|
||||
fStream : TStream;
|
||||
fBuf : Array of Char;
|
||||
FBufLen : integer;
|
||||
fPos : integer;
|
||||
fDeltaPos : integer;
|
||||
fFloatType : char;
|
||||
fSourceLine : integer;
|
||||
fToken : TParserToken;
|
||||
fEofReached : boolean;
|
||||
fLastTokenStr : string;
|
||||
function GetTokenName(aTok : TParserToken) : string;
|
||||
procedure LoadBuffer;
|
||||
procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
function GetAlphaNum : string;
|
||||
procedure HandleNewLine;
|
||||
procedure SkipBOM;
|
||||
procedure SkipSpaces;
|
||||
procedure SkipWhitespace;
|
||||
procedure HandleEof;
|
||||
procedure HandleAlphaNum;
|
||||
procedure HandleNumber;
|
||||
procedure HandleHexNumber;
|
||||
function HandleQuotedString : string;
|
||||
Function HandleDecimalCharacter: char;
|
||||
procedure HandleString;
|
||||
procedure HandleMinus;
|
||||
procedure HandleUnknown;
|
||||
public
|
||||
// Input stream is expected to be UTF16 !
|
||||
constructor Create(Stream: TStream);
|
||||
destructor Destroy; override;
|
||||
procedure CheckToken(T: TParserToken);
|
||||
procedure CheckTokenSymbol(const S: string);
|
||||
procedure Error(const Ident: string);
|
||||
procedure ErrorFmt(const Ident: string; const Args: array of JSValue);
|
||||
procedure ErrorStr(const Message: string);
|
||||
procedure HexToBinary(Stream: TStream);
|
||||
function NextToken: TParserToken;
|
||||
function SourcePos: Longint;
|
||||
function TokenComponentIdent: string;
|
||||
function TokenFloat: Double;
|
||||
function TokenInt: NativeInt;
|
||||
function TokenString: string;
|
||||
function TokenSymbolIs(const S: string): Boolean;
|
||||
property FloatType: Char read fFloatType;
|
||||
property SourceLine: Integer read fSourceLine;
|
||||
property Token: TParserToken read fToken;
|
||||
end;
|
||||
|
||||
|
||||
{ TObjectStreamConverter }
|
||||
|
||||
TObjectTextEncoding = (oteDFM,oteLFM);
|
||||
@ -1251,6 +1330,34 @@ type
|
||||
Property Indent : String Read FIndent Write Findent;
|
||||
end;
|
||||
|
||||
{ TObjectTextConverter }
|
||||
|
||||
TObjectTextConverter = Class
|
||||
private
|
||||
FParser: TParser;
|
||||
private
|
||||
FInput: TStream;
|
||||
Foutput: TStream;
|
||||
procedure WriteDouble(e: double);
|
||||
procedure WriteDWord(lw: longword);
|
||||
procedure WriteInteger(value: nativeInt);
|
||||
procedure WriteLString(const s: String);
|
||||
procedure WriteQWord(q: nativeint);
|
||||
procedure WriteString(s: String);
|
||||
procedure WriteWord(w: word);
|
||||
procedure WriteWString(const s: WideString);
|
||||
procedure ProcessObject; virtual;
|
||||
procedure ProcessProperty; virtual;
|
||||
procedure ProcessValue; virtual;
|
||||
procedure ProcessWideString(const left: string);
|
||||
Property Parser : TParser Read FParser;
|
||||
Public
|
||||
// Input stream must be UTF16 !
|
||||
procedure ObjectTextToBinary(aInput, aOutput: TStream);
|
||||
Procedure Execute; virtual;
|
||||
Property Input : TStream Read FInput Write FInput;
|
||||
Property Output: TStream Read Foutput Write Foutput;
|
||||
end;
|
||||
|
||||
type
|
||||
TIdentMapEntry = record
|
||||
@ -1284,8 +1391,10 @@ procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
|
||||
procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings);
|
||||
procedure ObjectBinaryToText(aInput, aOutput: TStream);
|
||||
procedure ObjectBinaryToText(aInput, aOutput: TStream; aEncoding: TObjectTextEncoding);
|
||||
procedure ObjectTextToBinary(aInput, aOutput: TStream);
|
||||
|
||||
Const
|
||||
// Some aliases
|
||||
vaSingle = vaDouble;
|
||||
vaExtended = vaDouble;
|
||||
vaLString = vaString;
|
||||
@ -1294,6 +1403,7 @@ Const
|
||||
vaWString = vaString;
|
||||
vaQWord = vaNativeInt;
|
||||
vaInt64 = vaNativeInt;
|
||||
toWString = toString;
|
||||
|
||||
implementation
|
||||
|
||||
@ -9483,6 +9593,823 @@ begin
|
||||
ObjectBinaryToText(aInput,aOutput,oteDFM);
|
||||
end;
|
||||
|
||||
{
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 1999-2007 by the Free Pascal development team
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{****************************************************************************}
|
||||
{* TParser *}
|
||||
{****************************************************************************}
|
||||
|
||||
const
|
||||
{$ifdef CPU16}
|
||||
{ Avoid too big local stack use for
|
||||
MSDOS tiny memory model that uses less than 4096
|
||||
bytes for total stack by default. }
|
||||
ParseBufSize = 512;
|
||||
{$else not CPU16}
|
||||
ParseBufSize = 4096;
|
||||
{$endif not CPU16}
|
||||
|
||||
TokNames : array[TParserToken] of string = (
|
||||
'?',
|
||||
'EOF',
|
||||
'Symbol',
|
||||
'String',
|
||||
'Integer',
|
||||
'Float',
|
||||
'-',
|
||||
'[',
|
||||
'(',
|
||||
'<',
|
||||
'{',
|
||||
']',
|
||||
')',
|
||||
'>',
|
||||
'}',
|
||||
',',
|
||||
'.',
|
||||
'=',
|
||||
':'
|
||||
);
|
||||
|
||||
function TParser.GetTokenName(aTok: TParserToken): string;
|
||||
begin
|
||||
Result:=TokNames[aTok]
|
||||
end;
|
||||
|
||||
procedure TParser.LoadBuffer;
|
||||
|
||||
var
|
||||
CharsRead,i: integer;
|
||||
|
||||
begin
|
||||
CharsRead:=0;
|
||||
for I:=0 to ParseBufSize-1 do
|
||||
if FStream.ReadData(FBuf[i])<>2 then
|
||||
Inc(CharsRead);
|
||||
Inc(FDeltaPos, CharsRead);
|
||||
FPos := 0;
|
||||
FBufLen := CharsRead;
|
||||
FEofReached:=CharsRead = 0;
|
||||
end;
|
||||
|
||||
procedure TParser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
if fPos>=FBufLen then
|
||||
LoadBuffer;
|
||||
end;
|
||||
|
||||
procedure TParser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
fLastTokenStr:=fLastTokenStr+fBuf[fPos];
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
|
||||
function TParser.IsNumber: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
Result:=fBuf[fPos] in ['0'..'9'];
|
||||
end;
|
||||
|
||||
function TParser.IsHexNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f'];
|
||||
end;
|
||||
|
||||
function TParser.IsAlpha: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z'];
|
||||
end;
|
||||
|
||||
function TParser.IsAlphaNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
Result:=IsAlpha or IsNumber;
|
||||
end;
|
||||
|
||||
function TParser.GetHexValue(c: char): byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
|
||||
begin
|
||||
case c of
|
||||
'0'..'9' : Result:=ord(c)-$30;
|
||||
'A'..'F' : Result:=ord(c)-$37; //-$41+$0A
|
||||
'a'..'f' : Result:=ord(c)-$57; //-$61+$0A
|
||||
end;
|
||||
end;
|
||||
|
||||
function TParser.GetAlphaNum: string;
|
||||
begin
|
||||
if not IsAlpha then
|
||||
ErrorFmt(SParserExpected,[GetTokenName(toSymbol)]);
|
||||
Result:='';
|
||||
while IsAlphaNum do
|
||||
begin
|
||||
Result:=Result+fBuf[fPos];
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.HandleNewLine;
|
||||
begin
|
||||
if fBuf[fPos]=#13 then //CR
|
||||
begin
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
if fBuf[fPos]=#10 then
|
||||
begin
|
||||
inc(fPos); //CR LF or LF
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
inc(fSourceLine);
|
||||
fDeltaPos:=-(fPos-1);
|
||||
end;
|
||||
|
||||
procedure TParser.SkipBOM;
|
||||
|
||||
begin
|
||||
// No BOM support
|
||||
end;
|
||||
|
||||
procedure TParser.SkipSpaces;
|
||||
begin
|
||||
while fBuf[fPos] in [' ',#9] do begin
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.SkipWhitespace;
|
||||
begin
|
||||
while true do
|
||||
begin
|
||||
case fBuf[fPos] of
|
||||
' ',#9 : SkipSpaces;
|
||||
#10,#13 : HandleNewLine
|
||||
else break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.HandleEof;
|
||||
begin
|
||||
fToken:=toEOF;
|
||||
fLastTokenStr:='';
|
||||
end;
|
||||
|
||||
procedure TParser.HandleAlphaNum;
|
||||
begin
|
||||
fLastTokenStr:=GetAlphaNum;
|
||||
fToken:=toSymbol;
|
||||
end;
|
||||
|
||||
procedure TParser.HandleNumber;
|
||||
type
|
||||
floatPunct = (fpDot,fpE);
|
||||
floatPuncts = set of floatPunct;
|
||||
var
|
||||
allowed : floatPuncts;
|
||||
begin
|
||||
fLastTokenStr:='';
|
||||
while IsNumber do
|
||||
ProcessChar;
|
||||
fToken:=toInteger;
|
||||
if (fBuf[fPos] in ['.','e','E']) then
|
||||
begin
|
||||
fToken:=toFloat;
|
||||
allowed:=[fpDot,fpE];
|
||||
while (fBuf[fPos] in ['.','e','E','0'..'9']) do
|
||||
begin
|
||||
case fBuf[fPos] of
|
||||
'.' : if fpDot in allowed then Exclude(allowed,fpDot) else break;
|
||||
'E','e' : if fpE in allowed then
|
||||
begin
|
||||
allowed:=[];
|
||||
ProcessChar;
|
||||
if (fBuf[fPos] in ['+','-']) then ProcessChar;
|
||||
if not (fBuf[fPos] in ['0'..'9']) then
|
||||
ErrorFmt(SParserInvalidFloat,[fLastTokenStr+fBuf[fPos]]);
|
||||
end
|
||||
else break;
|
||||
end;
|
||||
ProcessChar;
|
||||
end;
|
||||
end;
|
||||
if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency
|
||||
begin
|
||||
fFloatType:=fBuf[fPos];
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
fToken:=toFloat;
|
||||
end
|
||||
else fFloatType:=#0;
|
||||
end;
|
||||
|
||||
procedure TParser.HandleHexNumber;
|
||||
var valid : boolean;
|
||||
begin
|
||||
fLastTokenStr:='$';
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
valid:=false;
|
||||
while IsHexNum do
|
||||
begin
|
||||
valid:=true;
|
||||
ProcessChar;
|
||||
end;
|
||||
if not valid then
|
||||
ErrorFmt(SParserInvalidInteger,[fLastTokenStr]);
|
||||
fToken:=toInteger;
|
||||
end;
|
||||
|
||||
function TParser.HandleQuotedString: string;
|
||||
begin
|
||||
Result:='';
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
while true do
|
||||
begin
|
||||
case fBuf[fPos] of
|
||||
#0 : ErrorStr(SParserUnterminatedString);
|
||||
#13,#10 : ErrorStr(SParserUnterminatedString);
|
||||
'''' : begin
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
if fBuf[fPos]<>'''' then exit;
|
||||
end;
|
||||
end;
|
||||
Result:=Result+fBuf[fPos];
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
end;
|
||||
|
||||
Function TParser.HandleDecimalCharacter : Char;
|
||||
|
||||
var
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
// read a word number
|
||||
i:=0;
|
||||
while IsNumber and (i<high(word)) do
|
||||
begin
|
||||
i:=i*10+Ord(fBuf[fPos])-ord('0');
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
if i>high(word) then i:=0;
|
||||
Result:=Char(i);
|
||||
end;
|
||||
|
||||
procedure TParser.HandleString;
|
||||
|
||||
var
|
||||
s: string;
|
||||
|
||||
begin
|
||||
fLastTokenStr:='';
|
||||
while true do
|
||||
begin
|
||||
case fBuf[fPos] of
|
||||
'''' :
|
||||
begin
|
||||
s:=HandleQuotedString;
|
||||
fLastTokenStr:=fLastTokenStr+s;
|
||||
end;
|
||||
'#' :
|
||||
begin
|
||||
fLastTokenStr:=fLastTokenStr+HandleDecimalCharacter;
|
||||
end;
|
||||
else break;
|
||||
end;
|
||||
end;
|
||||
fToken:=Classes.toString
|
||||
end;
|
||||
|
||||
procedure TParser.HandleMinus;
|
||||
begin
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
if IsNumber then
|
||||
begin
|
||||
HandleNumber;
|
||||
fLastTokenStr:='-'+fLastTokenStr;
|
||||
end
|
||||
else
|
||||
begin
|
||||
fToken:=toMinus;
|
||||
fLastTokenStr:='-';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.HandleUnknown;
|
||||
begin
|
||||
fToken:=toUnknown;
|
||||
fLastTokenStr:=fBuf[fPos];
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
end;
|
||||
|
||||
constructor TParser.Create(Stream: TStream);
|
||||
begin
|
||||
fStream:=Stream;
|
||||
SetLength(fBuf,ParseBufSize);
|
||||
fBufLen:=0;
|
||||
fPos:=0;
|
||||
fDeltaPos:=1;
|
||||
fSourceLine:=1;
|
||||
fEofReached:=false;
|
||||
fLastTokenStr:='';
|
||||
fFloatType:=#0;
|
||||
fToken:=toEOF;
|
||||
LoadBuffer;
|
||||
SkipBom;
|
||||
NextToken;
|
||||
end;
|
||||
|
||||
destructor TParser.Destroy;
|
||||
|
||||
Var
|
||||
aCount : Integer;
|
||||
|
||||
begin
|
||||
aCount:=Length(fLastTokenStr)*2;
|
||||
fStream.Position:=SourcePos-aCount;
|
||||
end;
|
||||
|
||||
procedure TParser.CheckToken(T: tParserToken);
|
||||
begin
|
||||
if fToken<>T then
|
||||
ErrorFmt(SParserWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]);
|
||||
end;
|
||||
|
||||
procedure TParser.CheckTokenSymbol(const S: string);
|
||||
begin
|
||||
CheckToken(toSymbol);
|
||||
if CompareText(fLastTokenStr,S)<>0 then
|
||||
ErrorFmt(SParserWrongTokenSymbol,[s,fLastTokenStr]);
|
||||
end;
|
||||
|
||||
procedure TParser.Error(const Ident: string);
|
||||
begin
|
||||
ErrorStr(Ident);
|
||||
end;
|
||||
|
||||
procedure TParser.ErrorFmt(const Ident: string; const Args: array of JSValue);
|
||||
begin
|
||||
ErrorStr(Format(Ident,Args));
|
||||
end;
|
||||
|
||||
procedure TParser.ErrorStr(const Message: string);
|
||||
begin
|
||||
raise EParserError.CreateFmt(Message+SParserLocInfo,[SourceLine,fPos+fDeltaPos,SourcePos]);
|
||||
end;
|
||||
|
||||
procedure TParser.HexToBinary(Stream: TStream);
|
||||
|
||||
var
|
||||
outbuf : TBytes;
|
||||
b : byte;
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
SetLength(OutBuf,ParseBufSize);
|
||||
i:=0;
|
||||
SkipWhitespace;
|
||||
while IsHexNum do
|
||||
begin
|
||||
b:=(GetHexValue(fBuf[fPos]) shl 4);
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
if not IsHexNum then
|
||||
Error(SParserUnterminatedBinValue);
|
||||
b:=b or GetHexValue(fBuf[fPos]);
|
||||
inc(fPos);
|
||||
CheckLoadBuffer;
|
||||
outbuf[i]:=b;
|
||||
inc(i);
|
||||
if i>=ParseBufSize then
|
||||
begin
|
||||
Stream.WriteBuffer(outbuf,i);
|
||||
i:=0;
|
||||
end;
|
||||
SkipWhitespace;
|
||||
end;
|
||||
if i>0 then
|
||||
Stream.WriteBuffer(outbuf,i);
|
||||
NextToken;
|
||||
end;
|
||||
|
||||
function TParser.NextToken: TParserToken;
|
||||
|
||||
Procedure SetToken(aToken : TParserToken);
|
||||
begin
|
||||
FToken:=aToken;
|
||||
Inc(fPos);
|
||||
end;
|
||||
|
||||
begin
|
||||
SkipWhiteSpace;
|
||||
if fEofReached then
|
||||
HandleEof
|
||||
else
|
||||
case fBuf[fPos] of
|
||||
'_','A'..'Z','a'..'z' : HandleAlphaNum;
|
||||
'$' : HandleHexNumber;
|
||||
'-' : HandleMinus;
|
||||
'0'..'9' : HandleNumber;
|
||||
'''','#' : HandleString;
|
||||
'[' : SetToken(toSetStart);
|
||||
'(' : SetToken(toListStart);
|
||||
'<' : SetToken(toCollectionStart);
|
||||
'{' : SetToken(toBinaryStart);
|
||||
']' : SetToken(toSetEnd);
|
||||
')' : SetToken(toListEnd);
|
||||
'>' : SetToken(toCollectionEnd);
|
||||
'}' : SetToken(toBinaryEnd);
|
||||
',' : SetToken(toComma);
|
||||
'.' : SetToken(toDot);
|
||||
'=' : SetToken(toEqual);
|
||||
':' : SetToken(toColon);
|
||||
else
|
||||
HandleUnknown;
|
||||
end;
|
||||
Result:=fToken;
|
||||
end;
|
||||
|
||||
function TParser.SourcePos: Longint;
|
||||
begin
|
||||
Result:=fStream.Position-fBufLen+fPos;
|
||||
end;
|
||||
|
||||
function TParser.TokenComponentIdent: string;
|
||||
begin
|
||||
if fToken<>toSymbol then
|
||||
ErrorFmt(SParserExpected,[GetTokenName(toSymbol)]);
|
||||
CheckLoadBuffer;
|
||||
while fBuf[fPos]='.' do
|
||||
begin
|
||||
ProcessChar;
|
||||
fLastTokenStr:=fLastTokenStr+GetAlphaNum;
|
||||
end;
|
||||
Result:=fLastTokenStr;
|
||||
end;
|
||||
|
||||
Function TParser.TokenFloat: double;
|
||||
|
||||
var
|
||||
errcode : integer;
|
||||
|
||||
begin
|
||||
Val(fLastTokenStr,Result,errcode);
|
||||
if errcode<>0 then
|
||||
ErrorFmt(SParserInvalidFloat,[fLastTokenStr]);
|
||||
end;
|
||||
|
||||
Function TParser.TokenInt: NativeInt;
|
||||
begin
|
||||
if not TryStrToInt64(fLastTokenStr,Result) then
|
||||
Result:=StrToQWord(fLastTokenStr); //second chance for malformed files
|
||||
end;
|
||||
|
||||
function TParser.TokenString: string;
|
||||
begin
|
||||
case fToken of
|
||||
toFloat : if fFloatType<>#0 then
|
||||
Result:=fLastTokenStr+fFloatType
|
||||
else Result:=fLastTokenStr;
|
||||
else
|
||||
Result:=fLastTokenStr;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TParser.TokenSymbolIs(const S: string): Boolean;
|
||||
begin
|
||||
Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
|
||||
end;
|
||||
|
||||
|
||||
procedure TObjectTextConverter.WriteWord(w : word); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
|
||||
begin
|
||||
Output.WriteBufferData(w);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteDWord(lw : longword); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
|
||||
begin
|
||||
Output.WriteBufferData(lw);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteQWord(q : NativeInt); {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
|
||||
begin
|
||||
Output.WriteBufferData(q);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteDouble(e : double);
|
||||
begin
|
||||
Output.WriteBufferData(e);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteString(s: String);
|
||||
|
||||
var
|
||||
i,size : byte;
|
||||
|
||||
begin
|
||||
if length(s)>255 then
|
||||
size:=255
|
||||
else
|
||||
size:=length(s);
|
||||
Output.WriteByte(size);
|
||||
For I:=1 to Length(S) do
|
||||
Output.WriteBufferData(s[i]);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteLString(Const s: String);
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
WriteDWord(Length(s));
|
||||
For I:=1 to Length(S) do
|
||||
Output.WriteBufferData(s[i]);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteWString(Const s: WideString);
|
||||
|
||||
var
|
||||
i : Integer;
|
||||
begin
|
||||
WriteDWord(Length(s));
|
||||
For I:=1 to Length(S) do
|
||||
Output.WriteBufferData(s[i]);
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.WriteInteger(value: NativeInt);
|
||||
|
||||
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));
|
||||
WriteWord(word(value));
|
||||
end else if (value >= -2147483648) and (value <= 2147483647) then begin
|
||||
Output.WriteByte(Ord(vaInt32));
|
||||
WriteDWord(longword(value));
|
||||
end else begin
|
||||
Output.WriteByte(ord(vaInt64));
|
||||
WriteQWord(qword(value));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.ProcessWideString(const left : string);
|
||||
|
||||
var
|
||||
ws : string;
|
||||
begin
|
||||
ws:=left+parser.TokenString;
|
||||
while (parser.NextToken = classes.toString) and (Parser.TokenString='+') do
|
||||
begin
|
||||
parser.NextToken; // Get next string fragment
|
||||
if not (parser.Token=Classes.toString) then
|
||||
parser.CheckToken(Classes.toString);
|
||||
ws:=ws+parser.TokenString;
|
||||
end;
|
||||
Output.WriteByte(Ord(vaWstring));
|
||||
WriteWString(ws);
|
||||
end;
|
||||
|
||||
|
||||
procedure TObjectTextConverter.ProcessValue;
|
||||
var
|
||||
flt: double;
|
||||
s: String;
|
||||
stream: TBytesStream;
|
||||
begin
|
||||
case parser.Token of
|
||||
toInteger:
|
||||
begin
|
||||
WriteInteger(parser.TokenInt);
|
||||
parser.NextToken;
|
||||
end;
|
||||
toFloat:
|
||||
begin
|
||||
Output.WriteByte(Ord(vaExtended));
|
||||
flt := Parser.TokenFloat;
|
||||
WriteDouble(flt);
|
||||
parser.NextToken;
|
||||
end;
|
||||
classes.toString:
|
||||
ProcessWideString('');
|
||||
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));
|
||||
WriteString(parser.TokenComponentIdent);
|
||||
end;
|
||||
Parser.NextToken;
|
||||
end;
|
||||
// Set
|
||||
toSetStart:
|
||||
begin
|
||||
parser.NextToken;
|
||||
Output.WriteByte(Ord(vaSet));
|
||||
if parser.Token <> toSetEnd then
|
||||
while True do
|
||||
begin
|
||||
parser.CheckToken(toSymbol);
|
||||
WriteString(parser.TokenString);
|
||||
parser.NextToken;
|
||||
if parser.Token = toSetEnd then
|
||||
break;
|
||||
parser.CheckToken(toComma);
|
||||
parser.NextToken;
|
||||
end;
|
||||
Output.WriteByte(0);
|
||||
parser.NextToken;
|
||||
end;
|
||||
// List
|
||||
toListStart:
|
||||
begin
|
||||
parser.NextToken;
|
||||
Output.WriteByte(Ord(vaList));
|
||||
while parser.Token <> toListEnd do
|
||||
ProcessValue;
|
||||
Output.WriteByte(0);
|
||||
parser.NextToken;
|
||||
end;
|
||||
// Collection
|
||||
toCollectionStart:
|
||||
begin
|
||||
parser.NextToken;
|
||||
Output.WriteByte(Ord(vaCollection));
|
||||
while parser.Token <> toCollectionEnd 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
|
||||
toBinaryStart:
|
||||
begin
|
||||
Output.WriteByte(Ord(vaBinary));
|
||||
stream := TBytesStream.Create;
|
||||
try
|
||||
parser.HexToBinary(stream);
|
||||
WriteDWord(stream.Size);
|
||||
Output.WriteBuffer(Stream.Bytes,Stream.Size);
|
||||
finally
|
||||
stream.Free;
|
||||
end;
|
||||
parser.NextToken;
|
||||
end;
|
||||
else
|
||||
parser.Error(SParserInvalidProperty);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.ProcessProperty;
|
||||
var
|
||||
name: String;
|
||||
begin
|
||||
// Get name of property
|
||||
parser.CheckToken(toSymbol);
|
||||
name := parser.TokenString;
|
||||
while True do begin
|
||||
parser.NextToken;
|
||||
if parser.Token <> toDot then break;
|
||||
parser.NextToken;
|
||||
parser.CheckToken(toSymbol);
|
||||
name := name + '.' + parser.TokenString;
|
||||
end;
|
||||
WriteString(name);
|
||||
parser.CheckToken(toEqual);
|
||||
parser.NextToken;
|
||||
ProcessValue;
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.ProcessObject;
|
||||
var
|
||||
Flags: Byte;
|
||||
ObjectName, ObjectType: String;
|
||||
ChildPos: Integer;
|
||||
begin
|
||||
if parser.TokenSymbolIs('OBJECT') then
|
||||
Flags :=0 { IsInherited := False }
|
||||
else begin
|
||||
if parser.TokenSymbolIs('INHERITED') then
|
||||
Flags := 1 { IsInherited := True; }
|
||||
else begin
|
||||
parser.CheckTokenSymbol('INLINE');
|
||||
Flags := 4;
|
||||
end;
|
||||
end;
|
||||
parser.NextToken;
|
||||
parser.CheckToken(toSymbol);
|
||||
ObjectName := '';
|
||||
ObjectType := parser.TokenString;
|
||||
parser.NextToken;
|
||||
if parser.Token = toColon then begin
|
||||
parser.NextToken;
|
||||
parser.CheckToken(toSymbol);
|
||||
ObjectName := ObjectType;
|
||||
ObjectType := parser.TokenString;
|
||||
parser.NextToken;
|
||||
if parser.Token = toSetStart then begin
|
||||
parser.NextToken;
|
||||
ChildPos := parser.TokenInt;
|
||||
parser.NextToken;
|
||||
parser.CheckToken(toSetEnd);
|
||||
parser.NextToken;
|
||||
Flags := Flags or 2;
|
||||
end;
|
||||
end;
|
||||
if Flags <> 0 then begin
|
||||
Output.WriteByte($f0 or Flags);
|
||||
if (Flags and 2) <> 0 then
|
||||
WriteInteger(ChildPos);
|
||||
end;
|
||||
WriteString(ObjectType);
|
||||
WriteString(ObjectName);
|
||||
|
||||
// Convert property list
|
||||
while not (parser.TokenSymbolIs('END') or
|
||||
parser.TokenSymbolIs('OBJECT') or
|
||||
parser.TokenSymbolIs('INHERITED') or
|
||||
parser.TokenSymbolIs('INLINE')) 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;
|
||||
|
||||
procedure TObjectTextConverter.ObjectTextToBinary(aInput, aOutput: TStream);
|
||||
|
||||
begin
|
||||
FinPut:=aInput;
|
||||
FOutput:=aOutput;
|
||||
Execute;
|
||||
end;
|
||||
|
||||
procedure TObjectTextConverter.Execute;
|
||||
begin
|
||||
If Not Assigned(Input) then
|
||||
raise EReadError.Create('Missing input stream');
|
||||
If Not Assigned(Output) then
|
||||
raise EReadError.Create('Missing output stream');
|
||||
FParser := TParser.Create(Input);
|
||||
try
|
||||
Output.WriteBufferData(FilerSignatureInt);
|
||||
ProcessObject;
|
||||
finally
|
||||
FParser.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ObjectTextToBinary(aInput, aOutput: TStream);
|
||||
|
||||
var
|
||||
Conv : TObjectTextConverter;
|
||||
|
||||
begin
|
||||
Conv:=TObjectTextConverter.Create;
|
||||
try
|
||||
Conv.ObjectTextToBinary(aInput, aOutput);
|
||||
finally
|
||||
Conv.free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
ClassList:=TJSObject.create(nil);
|
||||
|
||||
@ -66,7 +66,17 @@ const
|
||||
SReadOnlyProperty = 'Property is read-only';
|
||||
SClassNotFound = 'Class "%s" not found';
|
||||
|
||||
SEmptyStreamIllegalWriter = 'Illegal Nil stream for TWriter constructor';
|
||||
SEmptyStreamIllegalWriter = 'Illegal Nil stream for TWriter constructor';
|
||||
SErrInvalidPropertyType = 'Invalid property type from streamed property: %d';
|
||||
SParserExpected = 'Wrong token type: %s expected';
|
||||
SParserInvalidFloat = 'Invalid floating point number: %s';
|
||||
SParserInvalidInteger = 'Invalid integer number: %s';
|
||||
SParserUnterminatedString = 'Unterminated string';
|
||||
SParserWrongTokenType = 'Wrong token type: %s expected but %s found';
|
||||
SParserWrongTokenSymbol = 'Wrong token symbol: %s expected but %s found';
|
||||
SParserLocInfo = ' (at %d,%d, stream offset %.8x)';
|
||||
SParserUnterminatedBinValue = 'Unterminated byte value';
|
||||
SParserInvalidProperty = 'Invalid property';
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
@ -82,24 +82,36 @@ Type
|
||||
Procedure TestTMethodComponent2;
|
||||
Procedure TestTMethodComponent2Text;
|
||||
// Read
|
||||
// ReadText will convert to text by calling text version, and read back after objecttexttobinary.
|
||||
Procedure TestTEmptyComponentRead;
|
||||
procedure TestTEmptyComponentReadText;
|
||||
Procedure TestTIntegerComponentRead;
|
||||
procedure TestTIntegerComponentReadText;
|
||||
Procedure TestTIntegerComponent2Read;
|
||||
Procedure TestTIntegerComponent2ReadText;
|
||||
Procedure TestTIntegerComponent3Read;
|
||||
Procedure TestTIntegerComponent3ReadText;
|
||||
Procedure TestTIntegerComponent4Read;
|
||||
Procedure TestTIntegerComponent5Read;
|
||||
Procedure TestTInt64ComponentRead;
|
||||
Procedure TestTInt64ComponentReadText;
|
||||
Procedure TestTInt64Component2Read;
|
||||
Procedure TestTInt64Component2ReadText;
|
||||
Procedure TestTInt64Component3Read;
|
||||
Procedure TestTInt64Component3ReadText;
|
||||
Procedure TestTInt64Component4Read;
|
||||
Procedure TestTInt64Component4ReadText;
|
||||
Procedure TestTInt64Component5Read;
|
||||
Procedure TestTInt64Component6Read;
|
||||
Procedure TestTStringComponentRead;
|
||||
Procedure TestTStringComponentReadText;
|
||||
Procedure TestTStringComponent2Read;
|
||||
Procedure TestTWideStringComponentRead;
|
||||
Procedure TestTWideStringComponentReadText;
|
||||
Procedure TestTWideStringComponent2Read;
|
||||
Procedure TestTSingleComponentRead;
|
||||
Procedure TestTDoubleComponentRead;
|
||||
Procedure TestTDoubleComponentReadText;
|
||||
Procedure TestTExtendedComponentRead;
|
||||
// Procedure TestTCompComponent;
|
||||
Procedure TestTCurrencyComponentRead;
|
||||
@ -107,24 +119,33 @@ Type
|
||||
Procedure TestTDateTimeComponent2Read;
|
||||
Procedure TestTDateTimeComponent3Read;
|
||||
Procedure TestTEnumComponentRead;
|
||||
Procedure TestTEnumComponentReadText;
|
||||
Procedure TestTEnumComponent2Read;
|
||||
Procedure TestTEnumComponent3Read;
|
||||
Procedure TestTEnumComponent4Read;
|
||||
Procedure TestTEnumComponent5Read;
|
||||
Procedure TestTSetComponentRead;
|
||||
Procedure TestTSetComponentReadText;
|
||||
Procedure TestTSetComponent2Read;
|
||||
Procedure TestTSetComponent3Read;
|
||||
Procedure TestTSetComponent4Read;
|
||||
Procedure TestTMultipleComponentRead;
|
||||
Procedure TestTMultipleComponentReadText;
|
||||
Procedure TestTPersistentComponentRead;
|
||||
Procedure TestTPersistentComponentReadText;
|
||||
Procedure TestTCollectionComponentRead;
|
||||
Procedure TestTCollectionComponentReadText;
|
||||
Procedure TestTCollectionComponent2Read;
|
||||
Procedure TestTCollectionComponent2ReadText;
|
||||
Procedure TestTCollectionComponent3Read;
|
||||
Procedure TestTCollectionComponent4Read;
|
||||
Procedure TestTCollectionComponent5Read;
|
||||
Procedure TestTOwnedComponentRead;
|
||||
Procedure TestTOwnedComponentReadText;
|
||||
Procedure TestTStreamedOwnedComponentRead;
|
||||
Procedure TestTStreamedOwnedComponentReadText;
|
||||
Procedure TestTStreamedOwnedComponentsRead;
|
||||
Procedure TestTStreamedOwnedComponentsReadText;
|
||||
end;
|
||||
|
||||
|
||||
@ -195,6 +216,22 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTEmptyComponentReadText;
|
||||
|
||||
Var
|
||||
C : TEmptyComponent;
|
||||
|
||||
begin
|
||||
TestTEmptyComponentText;
|
||||
C:=TEmptyComponent.Create(Nil);
|
||||
try
|
||||
LoadFromtextStream(C);
|
||||
AssertEquals('Name','TestTEmptyComponent',C.Name);
|
||||
finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure TTestComponentStream.TestTIntegerComponent;
|
||||
|
||||
|
||||
@ -248,6 +285,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponentReadText;
|
||||
|
||||
Var
|
||||
C : TIntegerComponent;
|
||||
|
||||
begin
|
||||
TestTIntegerComponentText;
|
||||
C:=TIntegerComponent.Create(Nil);
|
||||
Try
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTIntegerComponent',C.Name);
|
||||
AssertEquals('IntProp',3,C.IntProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponent2Read;
|
||||
|
||||
Var
|
||||
@ -265,7 +319,24 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponent2ReadText;
|
||||
Var
|
||||
C : TIntegerComponent2;
|
||||
|
||||
begin
|
||||
TestTIntegerComponent2Text;
|
||||
C:=TIntegerComponent2.Create(Nil);
|
||||
Try
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTIntegerComponent2',C.Name);
|
||||
AssertEquals('IntProp',1024,C.IntProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponent3Read;
|
||||
|
||||
Var
|
||||
C : TIntegerComponent3;
|
||||
|
||||
@ -281,6 +352,22 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponent3ReadText;
|
||||
Var
|
||||
C : TIntegerComponent3;
|
||||
|
||||
begin
|
||||
TestTIntegerComponent3Text;
|
||||
C:=TIntegerComponent3.Create(Nil);
|
||||
Try
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTIntegerComponent3',C.Name);
|
||||
AssertEquals('IntProp',262144,C.IntProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTIntegerComponent4Read;
|
||||
|
||||
Var
|
||||
@ -333,6 +420,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64ComponentReadText;
|
||||
Var
|
||||
C : TInt64Component;
|
||||
|
||||
begin
|
||||
TestTInt64ComponentText;
|
||||
C:=TInt64Component.Create(Nil);
|
||||
Try
|
||||
C.Int64Prop:=0;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTInt64Component',C.Name);
|
||||
AssertEquals('Int64Prop',4,C.Int64Prop);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component2Read;
|
||||
|
||||
Var
|
||||
@ -351,6 +455,24 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component2ReadText;
|
||||
|
||||
Var
|
||||
C : TInt64Component2;
|
||||
|
||||
begin
|
||||
TestTInt64Component2Text;
|
||||
C:=TInt64Component2.Create(Nil);
|
||||
Try
|
||||
C.Int64Prop:=0;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTInt64Component2',C.Name);
|
||||
AssertEquals('Int64Prop',2 shl 9,C.Int64Prop);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component3Read;
|
||||
|
||||
Var
|
||||
@ -369,6 +491,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component3ReadText;
|
||||
Var
|
||||
C : TInt64Component3;
|
||||
|
||||
begin
|
||||
TestTInt64Component3Text;
|
||||
C:=TInt64Component3.Create(Nil);
|
||||
Try
|
||||
C.Int64Prop:=0;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTInt64Component3',C.Name);
|
||||
AssertEquals('Int64Prop',2 shl 17,C.Int64Prop);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component4Read;
|
||||
|
||||
Var
|
||||
@ -387,6 +526,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component4ReadText;
|
||||
Var
|
||||
C : TInt64Component4;
|
||||
|
||||
begin
|
||||
TestTInt64Component4Text;
|
||||
C:=TInt64Component4.Create(Nil);
|
||||
Try
|
||||
C.Int64Prop:=0;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTInt64Component4',C.Name);
|
||||
AssertEquals('Int64Prop',NativeInt(MaxInt)+NativeInt(2 shl 14),C.Int64Prop);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTInt64Component5Read;
|
||||
|
||||
Var
|
||||
@ -441,6 +597,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStringComponentReadText;
|
||||
Var
|
||||
C : TStringComponent;
|
||||
|
||||
begin
|
||||
TestTStringComponentText;
|
||||
C:=TStringComponent.Create(Nil);
|
||||
Try
|
||||
C.StringProp:='';
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTStringComponent',C.Name);
|
||||
AssertEquals('StringProp','A string',C.StringProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStringComponent2Read;
|
||||
|
||||
Var
|
||||
@ -477,6 +650,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTWideStringComponentReadText;
|
||||
Var
|
||||
C : TWideStringComponent;
|
||||
|
||||
begin
|
||||
TestTWideStringComponentText;
|
||||
C:=TWideStringComponent.Create(Nil);
|
||||
Try
|
||||
C.WideStringProp:='abc';
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTWideStringComponent',C.Name);
|
||||
AssertEquals('WideStringProp','Some WideString',C.WideStringProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTWideStringComponent2Read;
|
||||
Var
|
||||
C : TWideStringComponent2;
|
||||
@ -530,6 +720,24 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTDoubleComponentReadText;
|
||||
Var
|
||||
C : TDoubleComponent;
|
||||
|
||||
begin
|
||||
TestTDoubleComponentText;
|
||||
C:=TDoubleComponent.Create(Nil);
|
||||
Try
|
||||
C.DoubleProp:=0;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTDoubleComponent',C.Name);
|
||||
// TODO: extend precision to 0.1
|
||||
AssertEquals('DoubleProp',2.34,C.DoubleProp,0.1);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTExtendedComponentRead;
|
||||
|
||||
Var
|
||||
@ -637,6 +845,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTEnumComponentReadText;
|
||||
Var
|
||||
C : TEnumComponent;
|
||||
|
||||
begin
|
||||
TestTEnumComponentText;
|
||||
C:=TEnumComponent.Create(Nil);
|
||||
Try
|
||||
C.Dice:=One;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTEnumComponent',C.Name);
|
||||
AssertTrue('Dice',four=C.Dice);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTEnumComponent2Read;
|
||||
|
||||
Var
|
||||
@ -729,6 +954,23 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTSetComponentReadText;
|
||||
Var
|
||||
C : TSetComponent;
|
||||
|
||||
begin
|
||||
TestTSetComponentText;
|
||||
C:=TSetComponent.Create(Nil);
|
||||
Try
|
||||
C.Throw:=[];
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTSetComponent',C.Name);
|
||||
AssertTrue('Throw',[two,five]=C.Throw);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTSetComponent2Read;
|
||||
|
||||
Var
|
||||
@ -787,6 +1029,7 @@ begin
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTMultipleComponentRead;
|
||||
|
||||
Var
|
||||
C : TMultipleComponent;
|
||||
|
||||
@ -810,6 +1053,31 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTMultipleComponentReadText;
|
||||
|
||||
Var
|
||||
C : TMultipleComponent;
|
||||
|
||||
begin
|
||||
TestTMultipleComponentText;
|
||||
C:=TMultipleComponent.Create(Nil);
|
||||
Try
|
||||
c.IntProp:=23;
|
||||
C.Dice:=six;
|
||||
C.CurrencyProp:=12.3;
|
||||
C.StringProp:='abc';
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTMultipleComponent',C.Name);
|
||||
AssertEquals('IntProp',1,C.IntProp);
|
||||
AssertEquals('StringProp','A String',C.StringProp);
|
||||
AssertEquals('CurrencyProp',2.3,C.CurrencyProp,0.1);
|
||||
AssertTrue('Dice',two=C.Dice);
|
||||
AssertTrue('Throw',[three,four]=C.Throw);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTPersistentComponentRead;
|
||||
|
||||
Var
|
||||
@ -830,6 +1098,25 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTPersistentComponentReadText;
|
||||
Var
|
||||
C : TPersistentComponent;
|
||||
|
||||
begin
|
||||
TestTPersistentComponentText;
|
||||
C:=TPersistentComponent.Create(Nil);
|
||||
Try
|
||||
C.Persist.AInteger:=36;
|
||||
C.Persist.AString:='nono';
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTPersistentComponent',C.Name);
|
||||
AssertEquals('Persist.AInteger',3,C.Persist.AInteger);
|
||||
AssertEquals('Persist.AString','A persistent string',C.Persist.AString);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTCollectionComponentRead;
|
||||
|
||||
Var
|
||||
@ -849,6 +1136,25 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTCollectionComponentReadText;
|
||||
|
||||
Var
|
||||
C : TCollectionComponent;
|
||||
|
||||
begin
|
||||
TestTCollectionComponentText;
|
||||
C:=TCollectionComponent.Create(Nil);
|
||||
Try
|
||||
C.Coll.Add;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTCollectionComponent',C.Name);
|
||||
// If the stream does not have a collection, it does not get cleared
|
||||
AssertEquals('Coll count',1,C.Coll.Count);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTCollectionComponent2Read;
|
||||
|
||||
Var
|
||||
@ -871,6 +1177,28 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTCollectionComponent2ReadText;
|
||||
|
||||
Var
|
||||
C : TCollectionComponent2;
|
||||
|
||||
begin
|
||||
TestTCollectionComponent2Text;
|
||||
C:=TCollectionComponent2.Create(Nil);
|
||||
Try
|
||||
C.Coll.Add;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTCollectionComponent2',C.Name);
|
||||
AssertEquals('Coll count',3,C.Coll.Count);
|
||||
AssertEquals('Correct class type',TTestItem,C.Coll.Items[0].ClassType);
|
||||
AssertEquals('Coll 0 Property','First',TTestItem(C.Coll.items[0]).StrProp);
|
||||
AssertEquals('Coll 1 Property','Second',TTestItem(C.Coll.Items[1]).StrProp);
|
||||
AssertEquals('Coll 2 Property','Third',TTestItem(C.Coll.Items[2]).StrProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTCollectionComponent3Read;
|
||||
|
||||
Var
|
||||
@ -956,7 +1284,29 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTOwnedComponentReadText;
|
||||
|
||||
Var
|
||||
C : TOwnedComponent;
|
||||
C2 : TComponent;
|
||||
|
||||
begin
|
||||
TestTOwnedComponentText;
|
||||
C:=TOwnedComponent.Create(Nil);
|
||||
try
|
||||
C2:=C.CompProp;
|
||||
C.CompProp:=nil;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTOwnedComponent',C.Name);
|
||||
AssertEquals('ComponentCount',1,C.ComponentCount);
|
||||
AssertSame('ComponentCount',C2,C.CompProp);
|
||||
finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStreamedOwnedComponentRead;
|
||||
|
||||
Var
|
||||
C : TStreamedOwnedComponent;
|
||||
|
||||
@ -977,7 +1327,30 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStreamedOwnedComponentReadText;
|
||||
|
||||
Var
|
||||
C : TStreamedOwnedComponent;
|
||||
|
||||
begin
|
||||
TestTStreamedOwnedComponentText;
|
||||
C:=TStreamedOwnedComponent.Create(Nil);
|
||||
Try
|
||||
C.Sub.Free;
|
||||
C.Sub:=Nil;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTStreamedOwnedComponent',C.Name);
|
||||
AssertNotNull('Have sub',C.Sub);
|
||||
AssertEquals('Correct class',TIntegerComponent,C.Sub.ClassType);
|
||||
AssertEquals('Name','Sub',C.Sub.Name);
|
||||
AssertEquals('Name',3,C.Sub.IntProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStreamedOwnedComponentsRead;
|
||||
|
||||
Var
|
||||
C : TStreamedOwnedComponents;
|
||||
|
||||
@ -1004,6 +1377,34 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestComponentStream.TestTStreamedOwnedComponentsReadText;
|
||||
|
||||
Var
|
||||
C : TStreamedOwnedComponents;
|
||||
|
||||
begin
|
||||
TestTStreamedOwnedComponentsText;
|
||||
C:=TStreamedOwnedComponents.Create(Nil);
|
||||
Try
|
||||
C.SubA.Free;
|
||||
C.SubA:=Nil;
|
||||
C.SubB.Free;
|
||||
C.SubB:=Nil;
|
||||
LoadFromTextStream(C);
|
||||
AssertEquals('Name','TestTStreamedOwnedComponents',C.Name);
|
||||
AssertNotNull('Have sub A',C.SubA);
|
||||
AssertEquals('Correct sub A class',TIntegerComponent,C.SubA.ClassType);
|
||||
AssertEquals('Name','SubA',C.SubA.Name);
|
||||
AssertEquals('Name',3,C.SubA.IntProp);
|
||||
AssertNotNull('Have sub B',C.SubB);
|
||||
AssertEquals('Correct sub B class',TStringComponent,C.SubB.ClassType);
|
||||
AssertEquals('Name','SubB',C.SubB.Name);
|
||||
AssertEquals('Name','A string',C.SubB.StringProp);
|
||||
Finally
|
||||
C.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure TTestComponentStream.TestTIntegerComponent2;
|
||||
|
||||
Var
|
||||
|
||||
@ -14,6 +14,7 @@ Type
|
||||
TTestStreaming = Class(TTestCase)
|
||||
Private
|
||||
FStream : TMemoryStream;
|
||||
FLastText : String;
|
||||
Function ReadByte : byte;
|
||||
Function ReadWord : Word;
|
||||
Function ReadInteger : LongInt;
|
||||
@ -28,15 +29,16 @@ Type
|
||||
Procedure ResetStream;
|
||||
Procedure SaveToStream(C : TComponent);
|
||||
Procedure LoadFromStream(C : TComponent);
|
||||
Procedure LoadFromTextStream(C : TComponent);
|
||||
Function ReadValue : TValueType;
|
||||
Procedure ExpectValue(AValue : TValueType);
|
||||
Procedure ExpectFlags(Flags : TFilerFlags; APosition : Integer);
|
||||
Procedure ExpectInteger(AValue : Integer);
|
||||
Procedure ExpectByte(AValue : Byte);
|
||||
Procedure ExpectInt64(AValue : Int64);
|
||||
Procedure ExpectInt64(AValue : NativeInt);
|
||||
Procedure ExpectBareString(AValue : String);
|
||||
Procedure ExpectString(AValue : String);
|
||||
Procedure ExpectSingle(AValue : Single);
|
||||
Procedure ExpectSingle(AValue : Double);
|
||||
Procedure ExpectExtended(AValue : Extended);
|
||||
Procedure ExpectCurrency(AValue : Currency);
|
||||
Procedure ExpectIdent(AValue : String);
|
||||
@ -46,6 +48,7 @@ Type
|
||||
Procedure ExpectSignature;
|
||||
Procedure ExpectEndOfStream;
|
||||
Procedure CheckAsString(const aData : String);
|
||||
Property LastText : String Read FLastText;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -178,11 +181,11 @@ begin
|
||||
Fail(Format('Wrong identifier %s, expected %s',[S,AValue]));
|
||||
end;
|
||||
|
||||
procedure TTestStreaming.ExpectInt64(AValue: Int64);
|
||||
procedure TTestStreaming.ExpectInt64(AValue: NativeInt);
|
||||
|
||||
Var
|
||||
V : TValueType;
|
||||
I : Int64;
|
||||
I : NativeInt;
|
||||
|
||||
begin
|
||||
V:=ReadValue;
|
||||
@ -236,7 +239,7 @@ begin
|
||||
Fail('Invalid signature %d, expected %d',[L,E]);
|
||||
end;
|
||||
|
||||
procedure TTestStreaming.ExpectSingle(AValue: Single);
|
||||
procedure TTestStreaming.ExpectSingle(AValue: Double);
|
||||
|
||||
Var
|
||||
S : Double;
|
||||
@ -350,6 +353,27 @@ begin
|
||||
FStream.ReadComponent(C);
|
||||
end;
|
||||
|
||||
procedure TTestStreaming.LoadFromTextStream(C: TComponent);
|
||||
|
||||
Var
|
||||
BS : TBytesStream;
|
||||
SS : TStringStream;
|
||||
|
||||
begin
|
||||
AssertTrue('Have text data',FLastText<>'');
|
||||
SS:=nil;
|
||||
SS:=TStringStream.Create(LastText);
|
||||
try
|
||||
BS:=TBytesStream.Create(Nil);
|
||||
ObjectTextToBinary(SS,BS);
|
||||
BS.Position:=0;
|
||||
BS.ReadComponent(C);
|
||||
finally
|
||||
SS.Free;
|
||||
BS.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestStreaming.TearDown;
|
||||
begin
|
||||
FreeAndNil(FStream);
|
||||
@ -430,6 +454,7 @@ begin
|
||||
SS.Free;
|
||||
end;
|
||||
AssertEquals('Stream to string',aData,DS);
|
||||
FLastText:=DS;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user