paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-05 04:17:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix streaming of chars outside ASCII range

Browse Source
This commit is contained in:
Michaël Van Canneyt 2021-09-12 11:21:09 +02:00
parent eaf7f8b282
commit bd6bc41f7f
6 changed files with 231 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
packages/rtl/classes.pas
View File

@ -1334,7 +1334,9 @@ type
FOutput : TStream;
FEncoding : TObjectTextEncoding;
Private
// Low level writing
FPlainStrings: Boolean;
// Low level writing
procedure Outchars(S : String); virtual;
procedure OutLn(s: String); virtual;
procedure OutStr(s: String); virtual;
procedure OutString(s: String); virtual;
@ -1356,6 +1358,8 @@ type
procedure ObjectBinaryToText(aInput, aOutput: TStream);
procedure ObjectBinaryToText(aInput, aOutput: TStream; aEncoding: TObjectTextEncoding);
Procedure Execute;
// use this to get previous streaming behavour: strings written as-is
Property PlainStrings : Boolean Read FPlainStrings Write FPlainStrings;
Property Input : TStream Read FInput Write FInput;
Property Output : TStream Read Foutput Write FOutput;
Property Encoding : TObjectTextEncoding Read FEncoding Write FEncoding;
@ -9760,62 +9764,67 @@ begin
OutStr(s + LineEnding);
end;
(*
procedure TObjectStreamConverter.Outchars(P, LastP : Pointer; CharToOrdFunc: CharToOrdFuncty; UseBytes: boolean = false);
procedure TObjectStreamConverter.Outchars(S: String);
var
res, NewStr: String;
w: Cardinal;
i,len,w: Cardinal;
InString, NewInString: Boolean;
SObj : TJSString absolute s;
begin
if p = nil then begin
res:= '''''';
end
if S = '' then
res:= ''''''
else
begin
res := '';
InString := False;
while P < LastP do
begin
NewInString := InString;
w := CharToOrdfunc(P);
if w = ord('''') then
begin //quote char
if not InString then
NewInString := True;
NewStr := '''''';
end
else if (Ord(w) >= 32) and ((Ord(w) < 127) or (UseBytes and (Ord(w)<256))) then
begin //printable ascii or bytes
if not InString then
NewInString := True;
NewStr := char(w);
end
begin
res := '';
InString := False;
len:= Length(S);
i:=0;
while i < Len do
begin
NewInString := InString;
w := SObj.charCodeAt(i);
if w = ord('''') then
begin //quote char
if not InString then
NewInString := True;
NewStr := '''''';
end
else if (w >= 32) and (w < 127) then
begin //printable ascii or bytes
if not InString then
NewInString := True;
NewStr := TJSString.FromCharCode(w);
end
else
begin //ascii control chars, non ascii
if InString then
NewInString := False;
NewStr := '#' + IntToStr(w);
end;
begin //ascii control chars, non ascii
if InString then
NewInString := False;
NewStr := '#' + IntToStr(w);
end;
if NewInString <> InString then
begin
NewStr := '''' + NewStr;
InString := NewInString;
end;
res := res + NewStr;
Inc(i);
end;
if InString then
res := res + '''';
end;
OutStr(res);
end;
*)
procedure TObjectStreamConverter.OutString(s: String);
begin
OutStr(S);
OutChars(S);
end;
(*
procedure TObjectStreamConverter.OutUtf8Str(s: String);
begin
@ -9962,7 +9971,10 @@ begin
OutLn(S);
end;
vaString: begin
OutString(''''+StringReplace(ReadString(vaString),'''','''''',[rfReplaceAll])+'''');
if PlainStrings then
OutStr( ''''+StringReplace(ReadString(vaString),'''','''''',[rfReplaceAll])+'''')
else
OutString(ReadString(vaString) {''''+StringReplace(ReadString(vaString),'''','''''',[rfReplaceAll])+''''});
OutLn('');
end;
vaIdent: OutLn(ReadStr);

20
packages/rtl/typinfo.pas
View File

@ -1074,6 +1074,9 @@ var
o: TJSObject;
Key: String;
n: NativeInt;
v : JSValue;
vs : TJSString absolute key;
begin
if PropInfo.TypeInfo.Kind=tkSet then
begin
@ -1086,6 +1089,19 @@ begin
if n<32 then
Result:=Result+(1 shl n);
end;
end else if PropInfo.TypeInfo.Kind=tkChar then
begin
v:=GetJSValueProp(Instance,PropInfo);
if isNumber(v) then
Result:=Longint(V)
else
begin
Key:=String(v);
If Key='' then
Result:=0
else
Result:=vs.CharCodeAt(0);
end
end else
Result:=longint(GetJSValueProp(Instance,PropInfo));
end;
@ -1108,7 +1124,9 @@ begin
if (1 shl i) and Value>0 then
o[str(i)]:=true;
SetJSValueProp(Instance,PropInfo,o);
end else
end else if PropInfo.TypeInfo.Kind=tkChar then
SetJSValueProp(Instance,PropInfo,TJSString.fromCharCode(Value))
else
SetJSValueProp(Instance,PropInfo,Value);
end;

188
test/tccompstreaming.pp
View File

@ -53,11 +53,15 @@ Type
Procedure TestTInt64Component4Text;
Procedure TestTInt64Component5;
Procedure TestTInt64Component6;
Procedure TestTCharComponent;
Procedure TestTCharComponentText;
Procedure TestTStringComponent;
Procedure TestTStringComponentText;
Procedure TestTStringComponent2;
Procedure TestTStringComponent3;
Procedure TestTStringComponent4;
Procedure TestTStringComponent3Text;
Procedure TestTStringComponent4Text;
Procedure TestTWideStringComponent;
Procedure TestTWideStringComponentText;
Procedure TestTWideStringComponent2;
@ -125,6 +129,7 @@ Type
Procedure TestTInt64Component4ReadText;
Procedure TestTInt64Component5Read;
Procedure TestTInt64Component6Read;
Procedure TestTCharComponentRead;
Procedure TestTStringComponentRead;
Procedure TestTStringComponentReadText;
Procedure TestTStringComponent2Read;
@ -192,7 +197,7 @@ Implementation
Const
LE = sLineBreak;
Procedure TTestComponentStream.TestTEmptyComponent;
procedure TTestComponentStream.TestTEmptyComponent;
Var
@ -254,7 +259,7 @@ begin
end;
end;
Procedure TTestComponentStream.TestTIntegerComponent;
procedure TTestComponentStream.TestTIntegerComponent;
Var
@ -601,6 +606,24 @@ begin
end;
end;
procedure TTestComponentStream.TestTCharComponentRead;
Var
C : TCharComponent;
begin
TestTCharComponent;
C:=TCharComponent.Create(Nil);
Try
C.CharProp:='A';
LoadFromStream(C);
AssertEquals('Name','TestTCharComponent',C.Name);
AssertEquals('StringProp',#10,C.CharProp);
Finally
C.Free;
end;
end;
procedure TTestComponentStream.TestTStringComponentRead;
Var
@ -1427,7 +1450,7 @@ begin
end;
end;
Procedure TTestComponentStream.TestTIntegerComponent2;
procedure TTestComponentStream.TestTIntegerComponent2;
Var
C : TComponent;
@ -1463,7 +1486,7 @@ begin
end;
Procedure TTestComponentStream.TestTIntegerComponent3;
procedure TTestComponentStream.TestTIntegerComponent3;
Var
C : TComponent;
@ -1499,7 +1522,7 @@ begin
end;
Procedure TTestComponentStream.TestTIntegerComponent4;
procedure TTestComponentStream.TestTIntegerComponent4;
Var
C : TComponent;
@ -1520,7 +1543,7 @@ begin
end;
Procedure TTestComponentStream.TestTIntegerComponent5;
procedure TTestComponentStream.TestTIntegerComponent5;
Var
C : TComponent;
@ -1543,7 +1566,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component;
procedure TTestComponentStream.TestTInt64Component;
Var
C : TComponent;
@ -1579,7 +1602,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component2;
procedure TTestComponentStream.TestTInt64Component2;
Var
C : TComponent;
@ -1615,7 +1638,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component3;
procedure TTestComponentStream.TestTInt64Component3;
Var
C : TComponent;
@ -1651,7 +1674,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component4;
procedure TTestComponentStream.TestTInt64Component4;
Var
C : TComponent;
@ -1687,7 +1710,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component5;
procedure TTestComponentStream.TestTInt64Component5;
Var
C : TComponent;
@ -1710,7 +1733,7 @@ begin
end;
Procedure TTestComponentStream.TestTInt64Component6;
procedure TTestComponentStream.TestTInt64Component6;
Var
C : TComponent;
@ -1732,8 +1755,44 @@ begin
end;
end;
procedure TTestComponentStream.TestTCharComponent;
Procedure TTestComponentStream.TestTStringComponent;
Var
C : TComponent;
begin
C:=TCharComponent.Create(Nil);
Try
SaveToStream(C);
ExpectSignature;
ExpectFlags([],0);
ExpectBareString('TCharComponent');
ExpectBareString('TestTCharComponent');
ExpectBareString('CharProp');
ExpectString(#10);
ExpectEndOfList;
ExpectEndOfList;
Finally
C.Free;
end;
end;
procedure TTestComponentStream.TestTCharComponentText;
Const
SData111 =
'object TestTCharComponent: TCharComponent'+sLineBreak+
' CharProp = #10'+sLineBreak+
'end'+sLineBreak;
begin
TestTCharComponent;
CheckAsString(SData111);
end;
procedure TTestComponentStream.TestTStringComponent;
Var
C : TComponent;
@ -1769,7 +1828,7 @@ begin
end;
Procedure TTestComponentStream.TestTStringComponent2;
procedure TTestComponentStream.TestTStringComponent2;
Var
C : TComponent;
@ -1790,6 +1849,7 @@ begin
end;
procedure TTestComponentStream.TestTStringComponent3;
Var
C : TComponent;
@ -1810,6 +1870,28 @@ begin
end;
end;
procedure TTestComponentStream.TestTStringComponent4;
Var
C : TComponent;
begin
C:=TStringComponent3.Create(Nil);
Try
TStringComponent3(C).StringProp:='A '#10' whitespace string';
SaveToStream(C);
ExpectSignature;
ExpectFlags([],0);
ExpectBareString('TStringComponent3');
ExpectBareString('TestTStringComponent3');
ExpectBareString('StringProp');
ExpectString('A '#10' whitespace string');
ExpectEndOfList;
ExpectEndOfList;
Finally
C.Free;
end;
end;
procedure TTestComponentStream.TestTStringComponent3Text;
Const
SData10 =
@ -1822,8 +1904,20 @@ begin
CheckAsString(SData10);
end;
procedure TTestComponentStream.TestTStringComponent4Text;
Const
SData101 =
'object TestTStringComponent3: TStringComponent3'+sLineBreak+
' StringProp = ''A ''#10'' whitespace string'''+sLineBreak+
'end'+sLineBreak;
Procedure TTestComponentStream.TestTWideStringComponent;
begin
TestTStringComponent4;
CheckAsString(SData101);
end;
procedure TTestComponentStream.TestTWideStringComponent;
Var
C : TComponent;
@ -1858,7 +1952,7 @@ begin
end;
Procedure TTestComponentStream.TestTWideStringComponent2;
procedure TTestComponentStream.TestTWideStringComponent2;
Var
C : TComponent;
@ -1879,7 +1973,7 @@ begin
end;
Procedure TTestComponentStream.TestTSingleComponent;
procedure TTestComponentStream.TestTSingleComponent;
Var
C : TComponent;
@ -1902,7 +1996,7 @@ begin
end;
Procedure TTestComponentStream.TestTDoubleComponent;
procedure TTestComponentStream.TestTDoubleComponent;
Var
C : TComponent;
@ -1929,7 +2023,7 @@ procedure TTestComponentStream.TestTDoubleComponentText;
Const
SData12 =
'object TestTDoubleComponent: TDoubleComponent'+sLineBreak+
' DoubleProp = 2.3E+000'+sLineBreak+
' DoubleProp = 2.3399999999999999E+000'+sLineBreak+
'end'+sLineBreak;
begin
@ -1938,7 +2032,7 @@ begin
end;
Procedure TTestComponentStream.TestTExtendedComponent;
procedure TTestComponentStream.TestTExtendedComponent;
Var
C : TComponent;
@ -1985,7 +2079,7 @@ begin
end;
*)
Procedure TTestComponentStream.TestTCurrencyComponent;
procedure TTestComponentStream.TestTCurrencyComponent;
Var
C : TComponent;
@ -2009,7 +2103,7 @@ begin
end;
end;
procedure TTestComponentStream.TestTCurrencyComponentTExt;
procedure TTestComponentStream.TestTCurrencyComponentText;
Const
SData13 =
'object TestTCurrencyComponent: TCurrencyComponent'+sLineBreak+
@ -2022,7 +2116,7 @@ begin
end;
Procedure TTestComponentStream.TestTDateTimeComponent;
procedure TTestComponentStream.TestTDateTimeComponent;
Var
C : TComponent;
@ -2045,7 +2139,7 @@ begin
end;
Procedure TTestComponentStream.TestTDateTimeComponent2;
procedure TTestComponentStream.TestTDateTimeComponent2;
Var
C : TComponent;
@ -2068,7 +2162,7 @@ begin
end;
Procedure TTestComponentStream.TestTDateTimeComponent3;
procedure TTestComponentStream.TestTDateTimeComponent3;
Var
C : TComponent;
@ -2091,7 +2185,7 @@ begin
end;
Procedure TTestComponentStream.TestTEnumComponent;
procedure TTestComponentStream.TestTEnumComponent;
Var
C : TComponent;
@ -2127,7 +2221,7 @@ begin
end;
Procedure TTestComponentStream.TestTEnumComponent2;
procedure TTestComponentStream.TestTEnumComponent2;
Var
C : TComponent;
@ -2154,7 +2248,7 @@ begin
end;
Procedure TTestComponentStream.TestTEnumComponent3;
procedure TTestComponentStream.TestTEnumComponent3;
Var
C : TComponent;
@ -2177,7 +2271,7 @@ begin
end;
Procedure TTestComponentStream.TestTEnumComponent4;
procedure TTestComponentStream.TestTEnumComponent4;
Var
C : TComponent;
@ -2197,7 +2291,7 @@ begin
end;
end;
Procedure TTestComponentStream.TestTEnumComponent5;
procedure TTestComponentStream.TestTEnumComponent5;
Var
C : TComponent;
@ -2218,7 +2312,7 @@ begin
end;
Procedure TTestComponentStream.TestTSetComponent;
procedure TTestComponentStream.TestTSetComponent;
Var
C : TComponent;
@ -2256,7 +2350,7 @@ begin
end;
Procedure TTestComponentStream.TestTSetComponent2;
procedure TTestComponentStream.TestTSetComponent2;
Var
C : TComponent;
@ -2284,7 +2378,7 @@ begin
end;
Procedure TTestComponentStream.TestTSetComponent3;
procedure TTestComponentStream.TestTSetComponent3;
Var
C : TComponent;
@ -2310,7 +2404,7 @@ begin
end;
Procedure TTestComponentStream.TestTSetComponent4;
procedure TTestComponentStream.TestTSetComponent4;
Var
C : TComponent;
@ -2332,7 +2426,7 @@ begin
end;
Procedure TTestComponentStream.TestTMultipleComponent;
procedure TTestComponentStream.TestTMultipleComponent;
Var
C : TComponent;
@ -2383,7 +2477,7 @@ begin
end;
Procedure TTestComponentStream.TestTPersistentComponent;
procedure TTestComponentStream.TestTPersistentComponent;
Var
C : TComponent;
@ -2422,7 +2516,7 @@ begin
end;
Procedure TTestComponentStream.TestTCollectionComponent;
procedure TTestComponentStream.TestTCollectionComponent;
Var
C : TComponent;
@ -2458,7 +2552,7 @@ begin
end;
Procedure TTestComponentStream.TestTCollectionComponent2;
procedure TTestComponentStream.TestTCollectionComponent2;
Var
C : TComponent;
@ -2515,7 +2609,7 @@ begin
end;
Procedure TTestComponentStream.TestTCollectionComponent3;
procedure TTestComponentStream.TestTCollectionComponent3;
Var
C : TComponent;
@ -2549,7 +2643,7 @@ begin
end;
Procedure TTestComponentStream.TestTCollectionComponent4;
procedure TTestComponentStream.TestTCollectionComponent4;
Var
C : TComponent;
@ -2576,7 +2670,7 @@ begin
end;
end;
Procedure TTestComponentStream.TestTCollectionComponent5;
procedure TTestComponentStream.TestTCollectionComponent5;
Var
C : TComponent;
@ -2611,7 +2705,7 @@ begin
end;
Procedure TTestComponentStream.TestTOwnedComponent;
procedure TTestComponentStream.TestTOwnedComponent;
Var
C : TComponent;
@ -2647,7 +2741,7 @@ begin
end;
Procedure TTestComponentStream.TestTStreamedOwnedComponent;
procedure TTestComponentStream.TestTStreamedOwnedComponent;
Var
C : TComponent;
@ -2689,7 +2783,7 @@ begin
CheckAsString(SData21);
end;
Procedure TTestComponentStream.TestTStreamedOwnedComponents;
procedure TTestComponentStream.TestTStreamedOwnedComponents;
Var
C : TComponent;
@ -2742,7 +2836,7 @@ begin
end;
Procedure TTestComponentStream.TestTMethodComponent;
procedure TTestComponentStream.TestTMethodComponent;
Var
C : TComponent;
@ -2778,7 +2872,7 @@ begin
end;
Procedure TTestComponentStream.TestTMethodComponent2;
procedure TTestComponentStream.TestTMethodComponent2;
Var
C : TComponent;
@ -2939,5 +3033,5 @@ begin
end;
begin
RegisterTests([TTestComponentStream,TTestCollectionStream]);
RegisterTests([TTestComponentStream{,TTestCollectionStream}]);
end.

4
test/tcstreaming.pp
View File

@ -44,7 +44,7 @@ Type
function ReadBareStr: string;
function ReadString(V : TValueType): string;
function ReadWideString(V : TValueType): WideString;
Procedure Fail(Fmt : String; Args : Array of JSValue); overload;
Procedure Fail(Fmt : String; Args : Array of const); overload;
Public
Procedure Setup; override;
Procedure TearDown; override;
@ -342,7 +342,7 @@ begin
end;
procedure TTestStreaming.Fail(Fmt: String; Args: array of jsvalue);
procedure TTestStreaming.Fail(Fmt: String; Args: array of Const);
begin
Fail(Format(Fmt,Args));
end;

20
test/testcomps.pp
View File

@ -139,6 +139,18 @@ Type
Property Int64Prop : NativeInt Read FIntProp Write FIntProp default 7;
end;
{ TCharComponent2 }
TCharComponent = Class(TComponent)
private
C: Char;
Public
Constructor Create(AOwner : TComponent); override;
Published
Property CharProp : Char Read C Write C;
end;
// String property.
TStringComponent = Class(TComponent)
private
@ -569,6 +581,14 @@ Type
Implementation
{ TCharComponent2 }
constructor TCharComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
C:=#10;
end;
{ TStringComponent3 }
constructor TStringComponent3.Create(AOwner: TComponent);

6
test/testrtl.lpr
View File

@ -26,8 +26,8 @@ program testrtl;
uses
browserconsole, consoletestrunner, frmrtlrun, simplelinkedlist,
tcstream,
// tccompstreaming,
// tcstream,
tccompstreaming,
// tcsyshelpers,
// tcgenarrayhelper,
// tcstringhelp,
@ -36,7 +36,7 @@ uses
// tcgenericqueue,
// tcgenericstack,
// tcsysutils,
tcclasses,
// tcclasses,
strutils,
sysutils;