View Issue Details

IDProjectCategoryView StatusLast Update
0036837FPCRTLpublic2020-04-07 21:17
ReporterBi0T1N Assigned ToMichael Van Canneyt  
PrioritynormalSeverityminorReproducibilityN/A
Status closedResolutionfixed 
Product Version3.3.1 
Fixed in Version3.3.1 
Summary0036837: Add ToObjectArray and ToStringArray for Delphi compatibility to TStrings*
DescriptionPatch 0001-Add-ToObjectArray-and-ToStringArray adds ToObjectArray and ToStringArray to TStrings classes for Delphi compatibility.
My implementation bases on their documentation as I don't have access to Delphi at the moment:
http://docwiki.embarcadero.com/Libraries/Rio/en/System.Classes.TStrings.ToObjectArray
http://docwiki.embarcadero.com/Libraries/Rio/en/System.Classes.TStrings.ToStringArray

Patch 0002-Fix-casing-of-TStrings just changes the wrong casing of TStrings in stringl.inc which I noticed while working on this.
TagsNo tags attached.
Fixed in Revision44635
FPCOldBugId
FPCTarget4.0.0
Attached Files

Activities

Bi0T1N

2020-03-28 13:28

reporter  

0001-Add-ToObjectArray-and-ToStringArray.patch (3,155 bytes)   
diff --git rtl/objpas/classes/classesh.inc rtl/objpas/classes/classesh.inc
index da3c309488..4928dcd6fa 100644
--- rtl/objpas/classes/classesh.inc
+++ rtl/objpas/classes/classesh.inc
@@ -758,6 +758,8 @@ type
     Procedure Slice(fromIndex: integer; aList : TStrings);
     Function Slice(fromIndex: integer) : TStrings;
     procedure SetText(TheText: PChar); virtual;
+    function ToObjectArray: TArray<TObject>; virtual;
+    function ToStringArray: TArray<String>;
     property AlwaysQuote: Boolean read FAlwaysQuote write FAlwaysQuote;
     property Capacity: Integer read GetCapacity write SetCapacity;
     property CommaText: string read GetCommaText write SetCommaText;
@@ -857,6 +859,7 @@ type
     procedure Sort(SortingAlgorithm: PSortingAlgorithm); virtual;
     procedure CustomSort(CompareFn: TStringListSortCompare); virtual;
     procedure CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm); virtual;
+    function ToObjectArray: TArray<TObject>; override;
     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
     property Sorted: Boolean read GetSorted write SetSorted;
     property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
@@ -914,6 +917,7 @@ type
     procedure Sort(SortingAlgorithm: PSortingAlgorithm); virtual;
     procedure CustomSort(CompareFn: TStringListSortCompare);
     procedure CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
+    function ToObjectArray: TArray<TObject>; override;
     property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
     property Sorted: Boolean read GetSorted write SetSorted;
     property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
diff --git rtl/objpas/classes/stringl.inc rtl/objpas/classes/stringl.inc
index 21092d1c6e..5cb396ab0f 100644
--- rtl/objpas/classes/stringl.inc
+++ rtl/objpas/classes/stringl.inc
@@ -1614,6 +1614,30 @@ begin
 end;
 
 
+
+
+function TStrings.ToObjectArray: TArray<TObject>;
+begin
+  // no function for TStrings class
+  SetLength(Result, 0);
+end;
+
+
+
+
+function TStrings.ToStringArray: TArray<String>;
+var
+  i: SizeInt;
+begin
+  SetLength(Result, Count);
+  for i := 0 to Count - 1 do
+  begin
+    Result[i] := Strings[i];
+  end;
+end;
+
+
+
 {****************************************************************************}
 {*                             TStringList                                  *}
 {****************************************************************************}
@@ -2102,6 +2126,17 @@ begin
   CustomSort(@StringListAnsiCompare, SortingAlgorithm);
 end;
 
+function TStringList.ToObjectArray: TArray<TObject>;
+var
+  i: SizeInt;
+begin
+  SetLength(Result, Count);
+  for i := 0 to Count - 1 do
+  begin
+    Result[i] := Objects[i];
+  end;
+end;
+
 {$else}
 
 { generics based implementation of TStringList follows }
@@ -2382,5 +2417,16 @@ begin
   end;
 end;
 
+function TStringList.ToObjectArray: TArray<TObject>;
+var
+  i: SizeInt;
+begin
+  SetLength(Result, Count);
+  for i := 0 to Count - 1 do
+  begin
+    Result[i] := Objects[i];
+  end;
+end;
+
 {$endif}
 
0002-Fix-casing-of-TStrings.patch (786 bytes)   
diff --git rtl/objpas/classes/stringl.inc rtl/objpas/classes/stringl.inc
index 5cb396ab0f..8356aa091e 100644
--- rtl/objpas/classes/stringl.inc
+++ rtl/objpas/classes/stringl.inc
@@ -61,12 +61,12 @@ begin
 end;
 
 {
-  For compatibility we can't add a Constructor to TSTrings to initialize
+  For compatibility we can't add a Constructor to TStrings to initialize
   the special characters. Therefore we add a routine which is called whenever
   the special chars are needed.
 }
 
-Procedure Tstrings.CheckSpecialChars;
+Procedure TStrings.CheckSpecialChars;
 
 begin
   If Not FSpecialCharsInited then
@@ -1008,7 +1008,7 @@ begin
 end;
 
 
-destructor TSTrings.Destroy;
+destructor TStrings.Destroy;
 
 begin
   if (FEncoding<>nil) and not TEncoding.IsStandardEncoding(FEncoding) then

jamie philbrook

2020-03-28 15:35

reporter   ~0121744

if we are going to do this lets take one extract step....

ToStringArrayRange(Start, End:Integer):Array of string;
ToObjectAtrrayRange(….

From those, the simple doing it all can call the range to aquire the complete list using the 0,GetCount-1 to indicate the complete list..

Bi0T1N

2020-04-03 18:59

reporter  

0003-Add-SetStrings-TStrings.patch (1,214 bytes)   
diff --git rtl/objpas/classes/classesh.inc rtl/objpas/classes/classesh.inc
index 4928dcd6fa..d830c3c7cd 100644
--- rtl/objpas/classes/classesh.inc
+++ rtl/objpas/classes/classesh.inc
@@ -754,6 +754,7 @@ type
     procedure SaveToStream(Stream: TStream); overload; virtual;
     procedure SaveToStream(Stream: TStream; IgnoreEncoding : Boolean); overload;
     procedure SaveToStream(Stream: TStream; AEncoding: TEncoding); overload; virtual;
+    procedure SetStrings(aSource: TStrings);
     function Shift : String;
     Procedure Slice(fromIndex: integer; aList : TStrings);
     Function Slice(fromIndex: integer) : TStrings;
diff --git rtl/objpas/classes/stringl.inc rtl/objpas/classes/stringl.inc
index 8356aa091e..0d69403993 100644
--- rtl/objpas/classes/stringl.inc
+++ rtl/objpas/classes/stringl.inc
@@ -1601,6 +1601,24 @@ end;
 
 
 
+procedure TStrings.SetStrings(aSource: TStrings);
+var
+  i: longint;
+begin
+  BeginUpdate;
+  try
+    if Count + aSource.Count > Capacity then
+      Capacity := Count + aSource.Count;
+    for i := 0 to aSource.Count - 1 do
+      self.Add(aSource[i]);
+  finally
+    EndUpdate;
+  end;
+end;
+
+
+
+
 Procedure TStrings.SetText(TheText: PChar);
 
 Var S : String;

Bi0T1N

2020-04-03 18:59

reporter   ~0121868

Last edited: 2020-04-03 19:00

View 2 revisions

Noticed that there is also SetStrings (http://docwiki.embarcadero.com/Libraries/Rio/en/System.Classes.TStrings.SetStrings) which isn't implemented yet. Attached a patch for it.

Maybe someone can update the title of the bugreport?

jamie philbrook

2020-04-03 23:59

reporter   ~0121877

But Tstrings already has that functionality. They call is AddStrings I believe.. which simply calls the code underneath.

No sense in adding methods that already exist that do the exact operation. I am sure there is already a SetStrings in there like that just under a different name.

Bi0T1N

2020-04-04 00:33

reporter   ~0121878

You're right that there is AddStrings already but it also sets the objects while SetStrings doesn't.

Sven Barth

2020-04-06 17:56

manager   ~0121978

The classes unit uses mode ObjFPC, so please provide a patch with the compatible generic syntax.

Bi0T1N

2020-04-06 22:00

reporter   ~0121985

Never used mode ObjFPC before but following code works, is it that what you mean?

program test;

{$mode ObjFPC}

uses
  SysUtils, Classes;

type
  TMyStrings = class(TStringList)
  public
    function ToObjectArray: specialize TArray<TObject>; virtual;
    function ToStringArray: specialize TArray<String>;
  end; 

function TMyStrings.ToObjectArray: specialize TArray<TObject>;
begin
  // no function for TStrings class
  SetLength(Result, 0);
end;

function TMyStrings.ToStringArray: specialize TArray<String>;
var
  i: SizeInt;
begin
  SetLength(Result, Count);
  for i := 0 to Count - 1 do
  begin
    Result[i] := Strings[i];
  end;
end;

var
  strlist: TMyStrings;
  str: String;

begin
  strlist := TMyStrings.Create;
  strlist.Add('hi');
  strlist.Add('bye');
  
  for str in strlist.ToStringArray do
    writeln(str);

  strlist.Free;
end.

jamie philbrook

2020-04-06 22:35

reporter   ~0121987

I only hope when Barth said Generic he didn't actually mean using GENERICS in there ?

My god man....

Bart Broersma

2020-04-06 23:00

reporter   ~0121990

Well, according to the Delphi docs it needs to return TArray<String/TObject>

jamie philbrook

2020-04-06 23:09

reporter   ~0121991

Last edited: 2020-04-06 23:11

View 2 revisions

Function TLineStrings.ToStringArrayRange(AStart, AEnd:Integer):TStringArray;
var
  I:integer;
Begin
  If AStart > AEnd then Exit;
  SetLength(Result, (AEnd-AStart)+1);
  For I := AStart to AEnd do
    Result[I-AStart]:= get(I);
end;
Function TLineStrings.ToStringArray:TStringArray;
Begin
  Result := ToStringArrayRange(0,Count-1);
end;
Function TlineStrings.ToObjectArrayRange(AStart, AEnd:Integer):TObjectArray;
Var
  I:Integer;
Begin
  if AStart > AEnd then exit;
  SetLength(Result, (AEnd-AStart)+1);
  For I := AStart to AEnd do
    Result[I-AStart]:= GetObject(I);
end;
Function TLineStrings.ToObjectArray:TobjectArray;
begin
  Result := ToObjectArrayRange(0,Count-1);
end;


I just stuck this in one of my current projects where I am using a Tstrings so ignore the TlineStrings heading, it would basically be the same as TStringList..
Just an idea but as you can see it has a range option so one can build from a specific range, too.

jamie philbrook

2020-04-07 00:49

reporter   ~0121993

I got thinking about this, you don't need an additional name tag... you can use a overload version of the same so that it all looks the same.

ToStringArray; or ToStringArray(Start, End);

That looks a little better I guess.

Michael Van Canneyt

2020-04-07 10:29

administrator   ~0121994

Last edited: 2020-04-07 10:31

View 2 revisions

Implemented, It can be entirely implemented in TStrings.

But as Jamie suggested added overloaded version.
You can just use TObjectDynArray and TStringDynArray.
They are equivalent to the generic variant in FPC, no need to use generics for this.

And setstrings does add the objects as well, I tested that in Delphi first.

Bi0T1N

2020-04-07 13:11

reporter   ~0122000

Last edited: 2020-04-07 13:15

View 2 revisions

If you allow ranges you should also use them:
  SetLength(Result,aEnd-aStart+1);
  For I:=0 to Count-1 do <-- doesn't care about aEnd and aStart -> overflowing Result
    Result[i]:=Objects[i];


Btw TStringDynArray misses a version for UnicodeStrings, otherwise $mode DelphiUnicode will still use Ansistring there

Michael Van Canneyt

2020-04-07 15:58

administrator   ~0122004

Hm. Misread that, sorry. Will check

Michael Van Canneyt

2020-04-07 16:04

administrator   ~0122005

Fixed, corrected my test, thanks for pointing it out!

Issue History

Date Modified Username Field Change
2020-03-28 13:28 Bi0T1N New Issue
2020-03-28 13:28 Bi0T1N File Added: 0001-Add-ToObjectArray-and-ToStringArray.patch
2020-03-28 13:28 Bi0T1N File Added: 0002-Fix-casing-of-TStrings.patch
2020-03-28 15:35 jamie philbrook Note Added: 0121744
2020-03-29 16:37 Michael Van Canneyt Assigned To => Michael Van Canneyt
2020-03-29 16:37 Michael Van Canneyt Status new => assigned
2020-04-03 18:59 Bi0T1N File Added: 0003-Add-SetStrings-TStrings.patch
2020-04-03 18:59 Bi0T1N Note Added: 0121868
2020-04-03 19:00 Bi0T1N Note Edited: 0121868 View Revisions
2020-04-03 23:59 jamie philbrook Note Added: 0121877
2020-04-04 00:33 Bi0T1N Note Added: 0121878
2020-04-06 17:56 Sven Barth Note Added: 0121978
2020-04-06 22:00 Bi0T1N Note Added: 0121985
2020-04-06 22:35 jamie philbrook Note Added: 0121987
2020-04-06 23:00 Bart Broersma Note Added: 0121990
2020-04-06 23:09 jamie philbrook Note Added: 0121991
2020-04-06 23:11 jamie philbrook Note Edited: 0121991 View Revisions
2020-04-07 00:49 jamie philbrook Note Added: 0121993
2020-04-07 10:29 Michael Van Canneyt Status assigned => resolved
2020-04-07 10:29 Michael Van Canneyt Resolution open => fixed
2020-04-07 10:29 Michael Van Canneyt Fixed in Version => 3.3.1
2020-04-07 10:29 Michael Van Canneyt Fixed in Revision => 44632
2020-04-07 10:29 Michael Van Canneyt FPCTarget => 4.0.0
2020-04-07 10:29 Michael Van Canneyt Note Added: 0121994
2020-04-07 10:31 Michael Van Canneyt Note Edited: 0121994 View Revisions
2020-04-07 13:11 Bi0T1N Status resolved => feedback
2020-04-07 13:11 Bi0T1N Resolution fixed => reopened
2020-04-07 13:11 Bi0T1N Note Added: 0122000
2020-04-07 13:15 Bi0T1N Note Edited: 0122000 View Revisions
2020-04-07 15:55 Michael Van Canneyt Status feedback => resolved
2020-04-07 15:55 Michael Van Canneyt Resolution reopened => fixed
2020-04-07 15:58 Michael Van Canneyt Status resolved => confirmed
2020-04-07 15:58 Michael Van Canneyt Note Added: 0122004
2020-04-07 16:04 Michael Van Canneyt Status confirmed => resolved
2020-04-07 16:04 Michael Van Canneyt Fixed in Revision 44632 => 44635
2020-04-07 16:04 Michael Van Canneyt Note Added: 0122005
2020-04-07 21:17 Bi0T1N Status resolved => closed