* Implement TStringStream, ObjectBinaryToText

packages/rtl/classes.pas

@@ -781,58 +781,69 @@ type
 
   { TCustomMemoryStream abstract class }
 
-    TCustomMemoryStream = class(TStream)
-    private
-      FMemory: TJSArrayBuffer;
-      FDataView : TJSDataView;
-      FDataArray : TJSUint8Array;
-      FSize, FPosition: PtrInt;
-      FSizeBoundsSeek : Boolean;
-      function GetDataArray: TJSUint8Array;
-      function GetDataView: TJSDataview;
-    protected
-      Function GetSize : NativeInt; Override;
-      function GetPosition: NativeInt; Override;
-      procedure SetPointer(Ptr: TJSArrayBuffer; ASize: PtrInt);
-      Property DataView : TJSDataview Read GetDataView;
-      Property DataArray : TJSUint8Array Read GetDataArray;
-    public
-      Class Function MemoryToBytes(Mem : TJSArrayBuffer) : TBytes; overload;
-      Class Function MemoryToBytes(Mem : TJSUint8Array) : TBytes; overload;
-      Class Function BytesToMemory(aBytes : TBytes) : TJSArrayBuffer;
-      function Read(Buffer : TBytes; Offset, Count: LongInt): LongInt; override;
-      function Seek(const Offset: NativeInt; Origin: TSeekOrigin): NativeInt; override;
-      procedure SaveToStream(Stream: TStream);
-      property Memory: TJSArrayBuffer read FMemory;
-      Property SizeBoundsSeek : Boolean Read FSizeBoundsSeek Write FSizeBoundsSeek;
-    end;
+  TCustomMemoryStream = class(TStream)
+  private
+    FMemory: TJSArrayBuffer;
+    FDataView : TJSDataView;
+    FDataArray : TJSUint8Array;
+    FSize, FPosition: PtrInt;
+    FSizeBoundsSeek : Boolean;
+    function GetDataArray: TJSUint8Array;
+    function GetDataView: TJSDataview;
+  protected
+    Function GetSize : NativeInt; Override;
+    function GetPosition: NativeInt; Override;
+    procedure SetPointer(Ptr: TJSArrayBuffer; ASize: PtrInt);
+    Property DataView : TJSDataview Read GetDataView;
+    Property DataArray : TJSUint8Array Read GetDataArray;
+  public
+    Class Function MemoryToBytes(Mem : TJSArrayBuffer) : TBytes; overload;
+    Class Function MemoryToBytes(Mem : TJSUint8Array) : TBytes; overload;
+    Class Function BytesToMemory(aBytes : TBytes) : TJSArrayBuffer;
+    function Read(Buffer : TBytes; Offset, Count: LongInt): LongInt; override;
+    function Seek(const Offset: NativeInt; Origin: TSeekOrigin): NativeInt; override;
+    procedure SaveToStream(Stream: TStream);
+    property Memory: TJSArrayBuffer read FMemory;
+    Property SizeBoundsSeek : Boolean Read FSizeBoundsSeek Write FSizeBoundsSeek;
+  end;
 
   { TMemoryStream }
 
-    TMemoryStream = class(TCustomMemoryStream)
-    private
-      FCapacity: PtrInt;
-      procedure SetCapacity(NewCapacity: PtrInt);
-    protected
-      function Realloc(var NewCapacity: PtrInt): TJSArrayBuffer; virtual;
-      property Capacity: PtrInt read FCapacity write SetCapacity;
-    public
-      destructor Destroy; override;
-      procedure Clear;
-      procedure LoadFromStream(Stream: TStream);
-      procedure SetSize(const NewSize: NativeInt); override;
-      function Write(const Buffer: TBytes; Offset, Count: LongInt): LongInt; override;
-    end;
+  TMemoryStream = class(TCustomMemoryStream)
+  private
+    FCapacity: PtrInt;
+    procedure SetCapacity(NewCapacity: PtrInt);
+  protected
+    function Realloc(var NewCapacity: PtrInt): TJSArrayBuffer; virtual;
+    property Capacity: PtrInt read FCapacity write SetCapacity;
+  public
+    destructor Destroy; override;
+    procedure Clear;
+    procedure LoadFromStream(Stream: TStream);
+    procedure SetSize(const NewSize: NativeInt); override;
+    function Write(const Buffer: TBytes; Offset, Count: LongInt): LongInt; override;
+  end;
 
 { TBytesStream }
 
-    TBytesStream = class(TMemoryStream)
-    private
-      function GetBytes: TBytes;
-    public
-      constructor Create(const ABytes: TBytes); virtual; overload;
-      property Bytes: TBytes read GetBytes;
-    end;
+  TBytesStream = class(TMemoryStream)
+  private
+    function GetBytes: TBytes;
+  public
+    constructor Create(const ABytes: TBytes); virtual; overload;
+    property Bytes: TBytes read GetBytes;
+  end;
+
+  { TStringStream }
+
+  TStringStream = class(TMemoryStream)
+  private
+    function GetDataString : String;
+  public
+    constructor Create(const aString: String); virtual; overload;
+    property DataString: String read GetDataString;
+  end;
+
 
   TFilerFlag = (ffInherited, ffChildPos, ffInline);
   TFilerFlags = set of TFilerFlag;
@@ -1201,6 +1212,46 @@ type
     property PropertyPath: string read FPropPath;
   end;
 
+  { TObjectStreamConverter }
+
+  TObjectTextEncoding = (oteDFM,oteLFM);
+
+  TObjectStreamConverter = Class
+  private
+     FIndent: String;
+     FInput : TStream;
+     FOutput : TStream;
+     FEncoding : TObjectTextEncoding;
+  Private
+    // Low level writing
+     procedure OutLn(s: String); virtual;
+     procedure OutStr(s: String); virtual;
+     procedure OutString(s: String); virtual;
+     // Low level reading
+     function ReadWord: word;
+     function ReadDWord: longword;
+     function ReadDouble: Double;
+     function ReadInt(ValueType: TValueType): NativeInt;
+     function ReadInt: NativeInt;
+     function ReadNativeInt: NativeInt;
+     function ReadStr: String;
+     function ReadString(StringType: TValueType): String; virtual;
+     // High-level
+     procedure ProcessBinary; virtual;
+     procedure ProcessValue(ValueType: TValueType; Indent: String); virtual;
+     procedure ReadObject(indent: String); virtual;
+     procedure ReadPropList(indent: String); virtual;
+   Public
+     procedure ObjectBinaryToText(aInput, aOutput: TStream);
+     procedure ObjectBinaryToText(aInput, aOutput: TStream; aEncoding: TObjectTextEncoding);
+     Procedure Execute;
+     Property Input : TStream Read FInput Write FInput;
+     Property Output : TStream Read Foutput Write FOutput;
+     Property Encoding : TObjectTextEncoding Read FEncoding Write FEncoding;
+     Property Indent : String Read FIndent Write Findent;
+   end;
+
+
 type
   TIdentMapEntry = record
     Value: Integer;
@@ -1231,6 +1282,8 @@ function CollectionsEqual(C1, C2: TCollection): Boolean;
 function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;
 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);
 
 Const
   vaSingle = vaDouble;
@@ -1261,6 +1314,46 @@ type
       AIntToIdent: TIntToIdent);
   end;
 
+{ TStringStream }
+
+function TStringStream.GetDataString: String;
+
+var
+   a : TJSUint16Array;
+
+begin
+  Result:=''; // Silence warning
+  a:=TJSUint16Array.New(Memory.slice(0,Size));
+  asm
+//    Result=String.fromCharCode.apply(null, new Uint16Array(a));
+    Result=String.fromCharCode.apply(null, a);
+  end;
+end;
+
+constructor TStringStream.Create(const aString: String);
+
+  Function StrToBuf(aLen : Integer) : TJSArrayBuffer;
+
+  var
+     I : Integer;
+
+  begin
+    Result:=TJSArrayBuffer.new(aLen*2);// 2 bytes for each char
+    With TJSUint16Array.new(Result) do
+      for i:=0 to aLen-1 do
+        values[i] := TJSString(aString).charCodeAt(i);
+  end;
+
+var
+  Len : Integer;
+
+begin
+  inherited Create;
+  Len:=Length(aString);
+  SetPointer(StrToBuf(len),Len*2);
+  FCapacity:=Len*2;
+end;
+
 constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
   AIntToIdent: TIntToIdent);
 begin
@@ -6471,6 +6564,25 @@ begin
   VisitResolveList(TReferenceInstancesVisitor.Create(Root,ReferenceRootName,Names));
 end;
 
+procedure ObjectBinaryToText(aInput, aOutput: TStream);
+begin
+  ObjectBinaryToText(aInput,aOutput,oteLFM);
+end;
+
+procedure ObjectBinaryToText(aInput, aOutput: TStream; aEncoding: TObjectTextEncoding);
+
+var
+  Conv : TObjectStreamConverter;
+
+begin
+  Conv:=TObjectStreamConverter.Create;
+  try
+    Conv.ObjectBinaryToText(aInput,aOutput,aEncoding);
+  finally
+    Conv.Free;
+  end;
+end;
+
 procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string);
 
 begin
@@ -9030,6 +9142,348 @@ begin
 end;
 
 
+procedure TObjectStreamConverter.OutStr(s: String);
+
+Var
+  I : integer;
+
+begin
+  For I:=1 to Length(S) do
+    Output.WriteBufferData(s[i]);
+end;
+
+procedure TObjectStreamConverter.OutLn(s: String);
+begin
+  OutStr(s + LineEnding);
+end;
+
+(*
+procedure TObjectStreamConverter.Outchars(P, LastP : Pointer; CharToOrdFunc: CharToOrdFuncty;  UseBytes: boolean = false);
+
+var
+  res, NewStr: String;
+  w: Cardinal;
+  InString, NewInString: Boolean;
+begin
+ if p = nil then begin
+  res:= '''''';
+ end
+ 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
+    else
+      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;
+    end;
+  if InString then
+    res := res + '''';
+  end;
+ OutStr(res);
+end;
+*)
+
+procedure TObjectStreamConverter.OutString(s: String);
+begin
+  OutStr(S);
+end;
+
+(*
+procedure TObjectStreamConverter.OutUtf8Str(s: String);
+begin
+  if Encoding=oteLFM then
+    OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd)
+  else
+    OutChars(Pointer(S),PChar(S)+Length(S),@Utf8ToOrd);
+end;
+*)
+
+function TObjectStreamConverter.ReadWord : word; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Input.ReadBufferData(Result);
+end;
+
+function TObjectStreamConverter.ReadDWord : longword; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Input.ReadBufferData(Result);
+end;
+
+function TObjectStreamConverter.ReadNativeInt : NativeInt; {$ifdef CLASSESINLINE}inline;{$endif CLASSESINLINE}
+begin
+  Input.ReadBufferData(Result);
+end;
+
+function TObjectStreamConverter.ReadInt(ValueType: TValueType): NativeInt;
+begin
+  case ValueType of
+    vaInt8: Result := ShortInt(Input.ReadByte);
+    vaInt16: Result := SmallInt(ReadWord);
+    vaInt32: Result := LongInt(ReadDWord);
+    vaNativeInt: Result := Int64(ReadNativeInt);
+  end;
+end;
+
+function TObjectStreamConverter.ReadInt: NativeInt;
+begin
+  Result := ReadInt(TValueType(Input.ReadByte));
+end;
+
+
+function TObjectStreamConverter.ReadDouble : Double;
+
+begin
+  Input.ReadBufferData(Result);
+end;
+
+function TObjectStreamConverter.ReadStr: String;
+
+var
+  l,i: Byte;
+  c : Char;
+
+begin
+  Input.ReadBufferData(L);
+  SetLength(Result,L);
+  For I:=1 to L do
+    begin
+    Input.ReadBufferData(C);
+    Result[i]:=C;
+    end;
+end;
+
+function TObjectStreamConverter.ReadString(StringType: TValueType): String;
+
+var
+  i: Integer;
+  C : Char;
+
+begin
+  Result:='';
+  if StringType<>vaString then
+    Raise EFilerError.Create('Invalid string type passed to ReadString');
+  i:=ReadDWord;
+  SetLength(Result, i);
+  for I:=1 to Length(Result) do
+    begin
+    Input.ReadbufferData(C);
+    Result[i]:=C;
+    end;
+end;
+
+procedure TObjectStreamConverter.ProcessBinary;
+
+var
+  ToDo, DoNow, i: LongInt;
+  lbuf: TBytes;
+  s: String;
+
+begin
+  ToDo := ReadDWord;
+  SetLength(lBuf,32);
+  OutLn('{');
+  while ToDo > 0 do
+    begin
+    DoNow := ToDo;
+    if DoNow > 32 then
+      DoNow := 32;
+    Dec(ToDo, DoNow);
+    s := Indent + '  ';
+    Input.ReadBuffer(lbuf, DoNow);
+    for i := 0 to DoNow - 1 do
+      s := s + IntToHex(lbuf[i], 2);
+    OutLn(s);
+  end;
+  OutLn(indent + '}');
+end;
+
+procedure TObjectStreamConverter.ProcessValue(ValueType: TValueType; Indent: String);
+
+
+var
+  s: String;
+{      len: LongInt; }
+  IsFirst: Boolean;
+{$ifndef FPUNONE}
+  ext: Extended;
+{$endif}
+
+begin
+  case ValueType of
+    vaList: begin
+        OutStr('(');
+        IsFirst := True;
+        while True do begin
+          ValueType := TValueType(Input.ReadByte);
+          if ValueType = vaNull then break;
+          if IsFirst then begin
+            OutLn('');
+            IsFirst := False;
+          end;
+          OutStr(Indent + '  ');
+          ProcessValue(ValueType, Indent + '  ');
+        end;
+        OutLn(Indent + ')');
+      end;
+    vaInt8: OutLn(IntToStr(ShortInt(Input.ReadByte)));
+    vaInt16: OutLn( IntToStr(SmallInt(ReadWord)));
+    vaInt32: OutLn(IntToStr(LongInt(ReadDWord)));
+    vaNativeInt: OutLn(IntToStr(ReadNativeInt));
+    vaDouble: begin
+        ext:=ReadDouble;
+        Str(ext,S);// Do not use localized strings.
+        OutLn(S);
+      end;
+    vaString: begin
+        OutString(''''+StringReplace(ReadString(vaString),'''','''''',[rfReplaceAll])+'''');
+        OutLn('');
+      end;
+    vaIdent: OutLn(ReadStr);
+    vaFalse: OutLn('False');
+    vaTrue: OutLn('True');
+    vaBinary: ProcessBinary;
+    vaSet: begin
+        OutStr('[');
+        IsFirst := True;
+        while True do begin
+          s := ReadStr;
+          if Length(s) = 0 then break;
+          if not IsFirst then OutStr(', ');
+          IsFirst := False;
+          OutStr(s);
+        end;
+        OutLn(']');
+      end;
+    vaNil:
+      OutLn('nil');
+    vaCollection: begin
+        OutStr('<');
+        while Input.ReadByte <> 0 do begin
+          OutLn(Indent);
+          Input.Seek(-1, soCurrent);
+          OutStr(indent + '  item');
+          ValueType := TValueType(Input.ReadByte);
+          if ValueType <> vaList then
+            OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
+          OutLn('');
+          ReadPropList(indent + '    ');
+          OutStr(indent + '  end');
+        end;
+        OutLn('>');
+      end;
+    {vaSingle: begin OutLn('!!Single!!'); exit end;
+    vaCurrency: begin OutLn('!!Currency!!'); exit end;
+    vaDate: begin OutLn('!!Date!!'); exit end;}
+    else
+      Raise EReadError.CreateFmt(SErrInvalidPropertyType,[Ord(ValueType)]);
+  end;
+end;
+
+
+procedure TObjectStreamConverter.ReadPropList(indent: String);
+
+
+begin
+  while Input.ReadByte <> 0 do begin
+    Input.Seek(-1, soCurrent);
+    OutStr(indent + ReadStr + ' = ');
+    ProcessValue(TValueType(Input.ReadByte), Indent);
+  end;
+end;
+
+procedure TObjectStreamConverter.ReadObject(indent: String);
+
+var
+  b: Byte;
+  ObjClassName, ObjName: String;
+  ChildPos: LongInt;
+
+begin
+  // Check for FilerFlags
+  b := Input.ReadByte;
+  if (b and $f0) = $f0 then begin
+    if (b and 2) <> 0 then ChildPos := ReadInt;
+  end else begin
+    b := 0;
+    Input.Seek(-1, soCurrent);
+  end;
+
+  ObjClassName := ReadStr;
+  ObjName := ReadStr;
+
+  OutStr(Indent);
+  if (b and 1) <> 0 then OutStr('inherited')
+  else
+   if (b and 4) <> 0 then OutStr('inline')
+   else OutStr('object');
+  OutStr(' ');
+  if ObjName <> '' then
+    OutStr(ObjName + ': ');
+  OutStr(ObjClassName);
+  if (b and 2) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
+  OutLn('');
+
+  ReadPropList(indent + '  ');
+
+  while Input.ReadByte <> 0 do begin
+    Input.Seek(-1, soCurrent);
+    ReadObject(indent + '  ');
+  end;
+  OutLn(indent + 'end');
+end;
+
+procedure TObjectStreamConverter.ObjectBinaryToText(aInput, aOutput: TStream; aEncoding: TObjectTextEncoding);
+
+begin
+  FInput:=aInput;
+  FOutput:=aOutput;
+  FEncoding:=aEncoding;
+  Execute;
+end;
+
+procedure TObjectStreamConverter.Execute;
+
+begin
+  if FIndent = '' then FInDent:='  ';
+  If Not Assigned(Input) then
+    raise EReadError.Create('Missing input stream');
+  If Not Assigned(Output) then
+    raise EReadError.Create('Missing output stream');
+  if Input.ReadDWord <> FilerSignatureInt then
+    raise EReadError.Create('Illegal stream image');
+  ReadObject('');
+end;
+
+procedure TObjectStreamConverter.ObjectBinaryToText(aInput, aOutput: TStream);
+begin
+  ObjectBinaryToText(aInput,aOutput,oteDFM);
+end;
+
+
 initialization
   ClassList:=TJSObject.create(nil);
 end.