From 0b21ea3b26ccd48fb8dee4f55c16876a41dde7cd Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 14 Jul 2019 09:56:12 +0000 Subject: [PATCH] * Add ObjectTextToBinary and TParser --- packages/rtl/classes.pas | 927 +++++++++++++++++++++++++++++++++++++ packages/rtl/rtlconsts.pas | 12 +- test/tccompstreaming.pp | 401 ++++++++++++++++ test/tcstreaming.pp | 35 +- 4 files changed, 1369 insertions(+), 6 deletions(-) diff --git a/packages/rtl/classes.pas b/packages/rtl/classes.pas index 808704c..2c3eac7 100644 --- a/packages/rtl/classes.pas +++ b/packages/rtl/classes.pas @@ -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 (ihigh(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); diff --git a/packages/rtl/rtlconsts.pas b/packages/rtl/rtlconsts.pas index 784de61..aa085d6 100644 --- a/packages/rtl/rtlconsts.pas +++ b/packages/rtl/rtlconsts.pas @@ -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 diff --git a/test/tccompstreaming.pp b/test/tccompstreaming.pp index a6f3f86..3689f5a 100644 --- a/test/tccompstreaming.pp +++ b/test/tccompstreaming.pp @@ -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 diff --git a/test/tcstreaming.pp b/test/tcstreaming.pp index 041b469..b31c163 100644 --- a/test/tcstreaming.pp +++ b/test/tcstreaming.pp @@ -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.