fpc/rtl/objpas/classes/stringl.inc
michael 93400f276c Merged revisions 9263-10571 via svnmerge from
svn+ssh://svn.freepascal.org/FPC/svn/fpc/branches/cleanroom

................
  r9269 | michael | 2007-11-17 13:58:31 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Cleaned initial list of tained routines
................
  r9270 | michael | 2007-11-17 14:00:25 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Test routines for cleanroom implementation
................
  r9271 | michael | 2007-11-17 14:04:43 +0100 (Sat, 17 Nov 2007) | 1 line
  
  DoVarClearArray also tainted
................
  r9272 | michael | 2007-11-17 15:25:04 +0100 (Sat, 17 Nov 2007) | 1 line
  
  * Removed possibly tainted code
................
  r9276 | Almindor | 2007-11-17 21:29:16 +0100 (Sat, 17 Nov 2007) | 2 lines
  
  * initial cleanroom implementation of TStringList.Find
................
  r9277 | Almindor | 2007-11-17 21:32:44 +0100 (Sat, 17 Nov 2007) | 2 lines
  
  * also commit forgotten part for "where would it instert" in case of sorted stringlist
................
  r9295 | michael | 2007-11-19 21:07:10 +0100 (Mon, 19 Nov 2007) | 1 line
  
  * More tests
................
  r9307 | michael | 2007-11-21 08:43:56 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * More tests and reorganization per unit
................
  r9308 | michael | 2007-11-21 08:47:58 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * More reorganization of files
................
  r9310 | michael | 2007-11-21 21:05:40 +0100 (Wed, 21 Nov 2007) | 1 line
  
  * Completed tccollection tests
................
  r9322 | marco | 2007-11-24 15:40:18 +0100 (Sat, 24 Nov 2007) | 1 line
  
   * getnamepath first version. Tests not run yet (fpcunit)
................
  r9337 | michael | 2007-11-27 09:21:31 +0100 (Tue, 27 Nov 2007) | 1 line
  
  * Removed TFPlist.Assign and TFPList.Extract
................
  r9340 | michael | 2007-11-27 22:33:07 +0100 (Tue, 27 Nov 2007) | 1 line
  
  Removed HandleSafeCallException 
................
  r9343 | Almindor | 2007-11-28 11:23:00 +0100 (Wed, 28 Nov 2007) | 2 lines
  
  * add cleanroom quicksort implementation [tested very little]
................
  r9344 | Almindor | 2007-11-28 11:25:54 +0100 (Wed, 28 Nov 2007) | 2 lines
  
  * update quicksort to use ExchangeItems instead of manual swap
................
  r9359 | vincents | 2007-11-30 20:10:03 +0100 (Fri, 30 Nov 2007) | 1 line
  
  + clean room implementation of HandleSafeCallException; compiles, but not tested.
................
  r9387 | michael | 2007-12-03 14:24:32 +0100 (Mon, 03 Dec 2007) | 1 line
  
  * Clean-room implementation of TParser by Giulio Bernardi
................
  r9396 | michael | 2007-12-05 21:36:41 +0100 (Wed, 05 Dec 2007) | 5 lines
  
  * Patch from Giulio Bernardi:
   - Fixes token positioning after HexToBinary 
   - Support for certain malformed negative integer values
................
  r9399 | michael | 2007-12-06 16:53:41 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * More tests for classes unit
................
  r9401 | michael | 2007-12-06 21:58:16 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * Added additional tests for collection streaming. Restructured
................
  r9402 | michael | 2007-12-06 22:35:56 +0100 (Thu, 06 Dec 2007) | 1 line
  
  * All compiles again, resolving references not quite yet done
................
  r9434 | michael | 2007-12-12 21:24:57 +0100 (Wed, 12 Dec 2007) | 1 line
  
  * New FindNestedComponent routine
................
  r9466 | michael | 2007-12-15 23:44:41 +0100 (Sat, 15 Dec 2007) | 1 line
  
  * Fixed all tests
................
  r9468 | michael | 2007-12-16 01:00:01 +0100 (Sun, 16 Dec 2007) | 1 line
  
  * Fixed reader fixup of references
................
  r9491 | joost | 2007-12-18 21:46:54 +0100 (Tue, 18 Dec 2007) | 3 lines
  
   * Implemented TWriter.WriteComponent
   * Implemented TWriter.WriteComponentData
   * Implemented TWriter.WriteDescendent
................
  r9492 | joost | 2007-12-18 21:56:32 +0100 (Tue, 18 Dec 2007) | 1 line
  
   * The BinaryObjectWriter of fpc stores TValueTypes as a byte, fixed the test for that
................
  r9566 | michael | 2007-12-29 15:53:32 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Clean (and complete) implementation of T(FP)List.Assign
................
  r9567 | michael | 2007-12-29 16:02:19 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Additional tests for reference resolving and TList.Assign
................
  r9568 | michael | 2007-12-29 16:12:33 +0100 (Sat, 29 Dec 2007) | 1 line
  
  * Cleanroom implementation of extract
................
  r9750 | yury | 2008-01-14 13:07:17 +0100 (Mon, 14 Jan 2008) | 1 line
  
  * My cleanroom implementation of DoVarClearArray.
................
  r10271 | michael | 2008-02-10 15:52:37 +0100 (Sun, 10 Feb 2008) | 1 line
  
  * Correct implementation committed
................
  r10273 | michael | 2008-02-10 17:08:59 +0100 (Sun, 10 Feb 2008) | 1 line
  
  * Added DecodeSoundexInt
................
  r10352 | vincents | 2008-02-18 08:23:18 +0100 (Mon, 18 Feb 2008) | 1 line
  
  + TStringList.Grow, used algorithm from TFPList.Expand
................
  r10353 | vincents | 2008-02-18 10:21:58 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * use new TStringList.Grow implementation from trunk
................
  r10354 | vincents | 2008-02-18 10:23:07 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * fixed TList tests
................
  r10355 | vincents | 2008-02-18 16:43:35 +0100 (Mon, 18 Feb 2008) | 1 line
  
  * fixed hint in test and removed session information from lpi
................
  r10356 | vincents | 2008-02-18 21:58:29 +0100 (Mon, 18 Feb 2008) | 1 line
  
  + implemented TStringList.Find
................
  r10358 | vincents | 2008-02-19 15:02:17 +0100 (Tue, 19 Feb 2008) | 1 line
  
  * fixed TTestTComponentNotifies test
................
  r10359 | vincents | 2008-02-19 15:48:43 +0100 (Tue, 19 Feb 2008) | 1 line
  
  * fixed memleak in TWriter.WriteProperties
................
  r10360 | vincents | 2008-02-19 15:49:20 +0100 (Tue, 19 Feb 2008) | 1 line
  
  + initial implementation of TReader.ReadCollection (needs further testing)
................
  r10364 | vincents | 2008-02-19 23:05:49 +0100 (Tue, 19 Feb 2008) | 1 line
  
  + TDataset.SetFieldValues (untested)
................
  r10365 | vincents | 2008-02-20 09:03:16 +0100 (Wed, 20 Feb 2008) | 1 line
  
  * initilize critical section used by resolving references
................
  r10366 | vincents | 2008-02-20 09:38:03 +0100 (Wed, 20 Feb 2008) | 2 lines
  
  * fixed resolve references test
  * removed unused variable
................
  r10369 | vincents | 2008-02-20 17:04:51 +0100 (Wed, 20 Feb 2008) | 1 line
  
  + initial version of TReader.FindComponentClass, works with a simple LCL application
................
  r10370 | michael | 2008-02-20 20:48:36 +0100 (Wed, 20 Feb 2008) | 1 line
  
  * Added tcollection stream read tests
................
  r10373 | vincents | 2008-02-21 00:33:10 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * TReader.FindComponentClass: also search in FieldTables of parent classes.
................
  r10374 | michael | 2008-02-21 11:00:04 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * Fix voor ResolveReferences
................
  r10376 | vincents | 2008-02-21 19:37:55 +0100 (Thu, 21 Feb 2008) | 1 line
  
  * reduced hints
................
  r10377 | vincents | 2008-02-22 14:56:22 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * add check for valid NewIndex in TFPList.Move, so that an invalid NewIndex doesn't lead to memleak
................
  r10378 | vincents | 2008-02-22 15:16:56 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * fixed TReader.ReadCollection in case more than one property was streamed
................
  r10379 | vincents | 2008-02-22 15:35:44 +0100 (Fri, 22 Feb 2008) | 3 lines
  
  + added another test for writing collections (shows how it should be written and thus read
  + added a test for a writing an enum with default value 
................
  r10380 | vincents | 2008-02-22 15:36:14 +0100 (Fri, 22 Feb 2008) | 1 line
  
  * fixed memleak
................
  r10381 | vincents | 2008-02-23 20:03:00 +0100 (Sat, 23 Feb 2008) | 1 line
  
  * fixed AV when streaming a component without published properties
................
  r10390 | michael | 2008-02-25 21:34:10 +0100 (Mon, 25 Feb 2008) | 1 line
  
  * Clean version of searchbuf inserted
................
  r10393 | vincents | 2008-02-26 23:06:14 +0100 (Tue, 26 Feb 2008) | 1 line
  
  * fixed TDataset.SetFieldValues
................
  r10398 | michael | 2008-02-27 21:58:49 +0100 (Wed, 27 Feb 2008) | 1 line
  
  * Added test for streaming 2 components
................
  r10400 | vincents | 2008-02-28 00:51:08 +0100 (Thu, 28 Feb 2008) | 1 line
  
  * improved tests for streaming components with owned subcomponents
................
  r10403 | vincents | 2008-02-28 22:19:32 +0100 (Thu, 28 Feb 2008) | 1 line
  
  * fixed writing child components
................
  r10441 | florian | 2008-03-04 20:11:46 +0100 (Tue, 04 Mar 2008) | 3 lines
  
  Initialized merge tracking via "svnmerge" with revisions "1-9261" from 
  http://svn.freepascal.org/svn/fpc/trunk
................
  r10444 | joost | 2008-03-05 11:31:07 +0100 (Wed, 05 Mar 2008) | 30 lines
  
  Merged revisions 9783,9786,9788,9814,9822,9825,9837-9850,9852,9854-9856,9863-9864,9867,9885,9895 via svnmerge from 
  svn+ssh://joost@svn.freepascal.org/FPC/svn/fpc/trunk
  
  ........
    r9783 | joost | 2008-01-18 23:52:13 +0100 (Fri, 18 Jan 2008) | 1 line
    
     * DigestTestREport makes it possible to write the unittest results to a testsuite-digest
  ........
    r9786 | joost | 2008-01-19 00:40:44 +0100 (Sat, 19 Jan 2008) | 1 line
    
     * Added dependency on paszlib to fcl-fpcunit
  ........
    r9788 | jonas | 2008-01-19 01:20:49 +0100 (Sat, 19 Jan 2008) | 2 lines
    
      + also add fpc-unit dependency on paszlib to build dependencies
  ........
    r9854 | joost | 2008-01-21 17:26:20 +0100 (Mon, 21 Jan 2008) | 2 lines
    
     * Added Comment and Category properties to TDigestResultsWriter
     * Write Comment and Category to digest.cfg
  ........
    r9885 | joost | 2008-01-23 22:56:34 +0100 (Wed, 23 Jan 2008) | 1 line
    
     * Write RelSrcDir to digest.cfg
  ........
    r9895 | joost | 2008-01-24 18:02:47 +0100 (Thu, 24 Jan 2008) | 1 line
    
     * Add dash between hostname and date in digest-tarfile
  ........
................
  r10445 | joost | 2008-03-05 11:47:26 +0100 (Wed, 05 Mar 2008) | 9 lines
  
  Merged revisions 10431 via svnmerge from 
  svn+ssh://joost@svn.freepascal.org/FPC/svn/fpc/trunk
  
  ........
    r10431 | joost | 2008-03-02 18:08:16 +0100 (Sun, 02 Mar 2008) | 1 line
    
     * Set Modified to false when te state of a dataset changes
  ........
................
  r10446 | joost | 2008-03-05 15:34:38 +0100 (Wed, 05 Mar 2008) | 9 lines
  
  Merged revisions 10350 via svnmerge from 
  svn+ssh://joost@svn.freepascal.org/FPC/svn/fpc/trunk
  
  ........
    r10350 | joost | 2008-02-17 22:14:26 +0100 (Sun, 17 Feb 2008) | 1 line
    
     * Fixed bug #8464
  ........
................
  r10490 | Almindor | 2008-03-15 11:18:42 +0100 (Sat, 15 Mar 2008) | 3 lines
  
  * add TDataLink.CalcFirstRecord cleanroom implementation (blind)
  * add TField.RefreshLookupList cleanroom implementation (blind)
................
  r10491 | Almindor | 2008-03-15 11:29:54 +0100 (Sat, 15 Mar 2008) | 2 lines
  
  * fix compilation of the TField.RefreshLookuplist;
................
  r10510 | Almindor | 2008-03-20 18:57:22 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * implement cleanroom TDataset.CalculateFields
................
  r10511 | Almindor | 2008-03-20 19:16:55 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add TDataSet.EnableControls cleanroom implementation
................
  r10512 | Almindor | 2008-03-20 19:27:27 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add TField.CalcLookupValue cleanroom implementation
................
  r10513 | Almindor | 2008-03-20 19:30:23 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * fix potential bug in cleanroom TField.RefreshLookupList
................
  r10514 | Almindor | 2008-03-20 19:33:13 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * add forgotten function call in TDataset.CalculateFields
................
  r10515 | Almindor | 2008-03-20 19:37:19 +0100 (Thu, 20 Mar 2008) | 2 lines
  
  * fix potential bug in cleanroom TDataLink.CalcFirstRecord
................
  r10531 | Almindor | 2008-03-22 10:57:40 +0100 (Sat, 22 Mar 2008) | 2 lines
  
  * implement cleanroom TDataSet.DataEvent
................
  r10534 | Almindor | 2008-03-22 21:30:02 +0100 (Sat, 22 Mar 2008) | 2 lines
  
  * fix cleanroom TDataset.DataEvent, make it call all connected datasources
................
  r10537 | michael | 2008-03-23 11:19:05 +0100 (Sun, 23 Mar 2008) | 6 lines
  
  * Fixed some issues:
    - Memleak in TReader.ReadPropValue. FFixups was re-allocated in beginreferences !
    - FPC behaves different from Delphi if no Default value is declared, it assumes a
      default of ord(TEnum)=0, same for sets.
    - Fixed MemLeak when a reference was resolved, Removed item was not freed.
................
  r10547 | Almindor | 2008-03-24 10:57:28 +0100 (Mon, 24 Mar 2008) | 2 lines
  
  * first fix to cleanroom TDataSet.DataEvent only 6 tests fail now :)
................
  r10553 | joost | 2008-03-24 19:58:33 +0100 (Mon, 24 Mar 2008) | 9 lines
  
  Merged revisions 10470 via svnmerge from 
  svn+ssh://joost@svn.freepascal.org/FPC/svn/fpc/trunk
  
  ........
    r10470 | joost | 2008-03-09 21:11:17 +0100 (Sun, 09 Mar 2008) | 1 line
    
     * Set TDataSet.InternalCalcFields if there are InternalCalcFields
  ........
................
  r10555 | joost | 2008-03-25 12:06:12 +0100 (Tue, 25 Mar 2008) | 9 lines
  
  Merged revisions 10519 via svnmerge from 
  svn+ssh://joost@svn.freepascal.org/FPC/svn/fpc/trunk
  
  ........
    r10519 | joost | 2008-03-21 14:38:44 +0100 (Fri, 21 Mar 2008) | 1 line
    
     * Fix for ValueOfKey for multiple-fields keys
  ........
................
  r10565 | Almindor | 2008-03-25 18:28:58 +0100 (Tue, 25 Mar 2008) | 2 lines
  
  * fix cleanroom TDataLink.CalcFirstRecord (passes tests now)
................

git-svn-id: trunk@10572 -
2008-03-27 20:15:57 +00:00

1463 lines
27 KiB
PHP

{
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 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.
**********************************************************************}
{****************************************************************************}
{* TStrings *}
{****************************************************************************}
// Function to quote text. Should move maybe to sysutils !!
// Also, it is not clear at this point what exactly should be done.
{ //!! is used to mark unsupported things. }
Function QuoteString (Const S : String; Quote : String) : String;
Var
I,J : Integer;
begin
J:=0;
Result:=S;
for i:=1to length(s) do
begin
inc(j);
if S[i]=Quote then
begin
System.Insert(Quote,Result,J);
inc(j);
end;
end;
Result:=Quote+Result+Quote;
end;
{
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;
begin
If Not FSpecialCharsInited then
begin
FQuoteChar:='"';
FDelimiter:=',';
FNameValueSeparator:='=';
FSpecialCharsInited:=true;
FLBS:=DefaultTextLineBreakStyle;
end;
end;
Function TStrings.GetLBS : TTextLineBreakStyle;
begin
CheckSpecialChars;
Result:=FLBS;
end;
Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle);
begin
CheckSpecialChars;
FLBS:=AValue;
end;
procedure TStrings.SetDelimiter(c:Char);
begin
CheckSpecialChars;
FDelimiter:=c;
end;
procedure TStrings.SetQuoteChar(c:Char);
begin
CheckSpecialChars;
FQuoteChar:=c;
end;
procedure TStrings.SetNameValueSeparator(c:Char);
begin
CheckSpecialChars;
FNameValueSeparator:=c;
end;
function TStrings.GetCommaText: string;
Var
C1,C2 : Char;
begin
CheckSpecialChars;
C1:=Delimiter;
C2:=QuoteChar;
Delimiter:=',';
QuoteChar:='"';
Try
Result:=GetDelimitedText;
Finally
Delimiter:=C1;
QuoteChar:=C2;
end;
end;
Function TStrings.GetDelimitedText: string;
Var
I : integer;
p : pchar;
begin
CheckSpecialChars;
result:='';
For i:=0 to count-1 do
begin
p:=pchar(strings[i]);
while not(p^ in [#0..' ',QuoteChar,Delimiter]) do
inc(p);
// strings in list may contain #0
if p<>pchar(strings[i])+length(strings[i]) then
Result:=Result+QuoteString (Strings[I],QuoteChar)
else
result:=result+strings[i];
if I<Count-1 then Result:=Result+Delimiter;
end;
If (Length(Result)=0)and(count=1) then
Result:=QuoteChar+QuoteChar;
end;
procedure TStrings.GetNameValue(Index : Integer; Var AName,AValue : String);
Var L : longint;
begin
CheckSpecialChars;
AValue:=Strings[Index];
L:=Pos(FNameValueSeparator,AValue);
If L<>0 then
begin
AName:=Copy(AValue,1,L-1);
System.Delete(AValue,1,L);
end
else
AName:='';
end;
function TStrings.ExtractName(const s:String):String;
var
L: Longint;
begin
CheckSpecialChars;
L:=Pos(FNameValueSeparator,S);
If L<>0 then
Result:=Copy(S,1,L-1)
else
Result:='';
end;
function TStrings.GetName(Index: Integer): string;
Var
V : String;
begin
GetNameValue(Index,Result,V);
end;
Function TStrings.GetValue(const Name: string): string;
Var
L : longint;
N : String;
begin
Result:='';
L:=IndexOfName(Name);
If L<>-1 then
GetNameValue(L,N,Result);
end;
Function TStrings.GetValueFromIndex(Index: Integer): string;
Var
N : String;
begin
GetNameValue(Index,N,Result);
end;
Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string);
begin
If (Value='') then
Delete(Index)
else
begin
If (Index<0) then
Index:=Add('');
CheckSpecialChars;
Strings[Index]:=GetName(Index)+FNameValueSeparator+Value;
end;
end;
procedure TStrings.ReadData(Reader: TReader);
begin
Reader.ReadListBegin;
BeginUpdate;
try
Clear;
while not Reader.EndOfList do
Add(Reader.ReadString);
finally
EndUpdate;
end;
Reader.ReadListEnd;
end;
Procedure TStrings.SetDelimitedText(const AValue: string);
var i,j:integer;
aNotFirst:boolean;
begin
CheckSpecialChars;
BeginUpdate;
i:=1;
aNotFirst:=false;
try
Clear;
while i<=length(AValue) do begin
// skip delimiter
if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
// skip spaces
while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
// read next string
if i<=length(AValue) then begin
if AValue[i]=FQuoteChar then begin
// next string is quoted
j:=i+1;
while (j<=length(AValue)) and
( (AValue[j]<>FQuoteChar) or
( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
else inc(j);
end;
// j is position of closing quote
Add( StringReplace (Copy(AValue,i+1,j-i-1),
FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
i:=j+1;
end else begin
// next string is not quoted
j:=i;
while (j<=length(AValue)) and
(Ord(AValue[j])>Ord(' ')) and
(AValue[j]<>FDelimiter) do inc(j);
Add( Copy(AValue,i,j-i));
i:=j;
end;
end else begin
if aNotFirst then Add('');
end;
// skip spaces
while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
aNotFirst:=true;
end;
finally
EndUpdate;
end;
end;
Procedure TStrings.SetCommaText(const Value: string);
Var
C1,C2 : Char;
begin
CheckSpecialChars;
C1:=Delimiter;
C2:=QuoteChar;
Delimiter:=',';
QuoteChar:='"';
Try
SetDelimitedText(Value);
Finally
Delimiter:=C1;
QuoteChar:=C2;
end;
end;
Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
begin
end;
Procedure TStrings.SetValue(const Name, Value: string);
Var L : longint;
begin
CheckSpecialChars;
L:=IndexOfName(Name);
if L=-1 then
Add (Name+FNameValueSeparator+Value)
else
Strings[L]:=Name+FNameValueSeparator+value;
end;
procedure TStrings.WriteData(Writer: TWriter);
var
i: Integer;
begin
Writer.WriteListBegin;
for i := 0 to Count - 1 do
Writer.WriteString(Strings[i]);
Writer.WriteListEnd;
end;
procedure TStrings.DefineProperties(Filer: TFiler);
var
HasData: Boolean;
begin
if Assigned(Filer.Ancestor) then
// Only serialize if string list is different from ancestor
if Filer.Ancestor.InheritsFrom(TStrings) then
HasData := not Equals(TStrings(Filer.Ancestor))
else
HasData := True
else
HasData := Count > 0;
Filer.DefineProperty('Strings', @ReadData, @WriteData, HasData);
end;
Procedure TStrings.Error(const Msg: string; Data: Integer);
begin
Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
end;
Procedure TStrings.Error(const Msg: pstring; Data: Integer);
begin
Raise EStringListError.CreateFmt(Msg^,[Data]) at get_caller_addr(get_frame);
end;
Function TStrings.GetCapacity: Integer;
begin
Result:=Count;
end;
Function TStrings.GetObject(Index: Integer): TObject;
begin
Result:=Nil;
end;
Function TStrings.GetTextStr: string;
Var P : Pchar;
I,L,NLS : Longint;
S,NL : String;
begin
CheckSpecialChars;
// Determine needed place
Case FLBS of
tlbsLF : NL:=#10;
tlbsCRLF : NL:=#13#10;
tlbsCR : NL:=#13;
end;
L:=0;
NLS:=Length(NL);
For I:=0 to count-1 do
L:=L+Length(Strings[I])+NLS;
Setlength(Result,L);
P:=Pointer(Result);
For i:=0 To count-1 do
begin
S:=Strings[I];
L:=Length(S);
if L<>0 then
System.Move(Pointer(S)^,P^,L);
P:=P+L;
For L:=1 to NLS do
begin
P^:=NL[L];
inc(P);
end;
end;
end;
Procedure TStrings.Put(Index: Integer; const S: string);
Var Obj : TObject;
begin
Obj:=Objects[Index];
Delete(Index);
InsertObject(Index,S,Obj);
end;
Procedure TStrings.PutObject(Index: Integer; AObject: TObject);
begin
// Empty.
end;
Procedure TStrings.SetCapacity(NewCapacity: Integer);
begin
// Empty.
end;
Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
Var
PS : PChar;
IP,L : Integer;
begin
L:=Length(Value);
S:='';
Result:=False;
If ((L-P)<0) then
exit;
if ((L-P)=0) and (not (value[P] in [#10,#13])) Then
Begin
s:=value[P];
inc(P);
Exit(True);
End;
PS:=PChar(Value)+P-1;
IP:=P;
While ((L-P)>=0) and (not (PS^ in [#10,#13])) do
begin
P:=P+1;
Inc(PS);
end;
SetLength (S,P-IP);
System.Move (Value[IP],Pointer(S)^,P-IP);
If (P<=L) and (Value[P]=#13) then
Inc(P);
If (P<=L) and (Value[P]=#10) then
Inc(P); // Point to character after #10(#13)
Result:=True;
end;
Procedure TStrings.SetTextStr(const Value: string);
Var
S : String;
P : Integer;
begin
Try
beginUpdate;
Clear;
P:=1;
While GetNextLine (Value,S,P) do
Add(S);
finally
EndUpdate;
end;
end;
Procedure TStrings.SetUpdateState(Updating: Boolean);
begin
end;
destructor TSTrings.Destroy;
begin
inherited destroy;
end;
Function TStrings.Add(const S: string): Integer;
begin
Result:=Count;
Insert (Count,S);
end;
Function TStrings.AddObject(const S: string; AObject: TObject): Integer;
begin
Result:=Add(S);
Objects[result]:=AObject;
end;
Procedure TStrings.Append(const S: string);
begin
Add (S);
end;
Procedure TStrings.AddStrings(TheStrings: TStrings);
Var Runner : longint;
begin
try
beginupdate;
For Runner:=0 to TheStrings.Count-1 do
self.AddObject (Thestrings[Runner],TheStrings.Objects[Runner]);
finally
EndUpdate;
end;
end;
Procedure TStrings.Assign(Source: TPersistent);
Var
S : TStrings;
begin
If Source is TStrings then
begin
S:=TStrings(Source);
BeginUpdate;
Try
clear;
FSpecialCharsInited:=S.FSpecialCharsInited;
FQuoteChar:=S.FQuoteChar;
FDelimiter:=S.FDelimiter;
FNameValueSeparator:=S.FNameValueSeparator;
AddStrings(S);
finally
EndUpdate;
end;
end
else
Inherited Assign(Source);
end;
Procedure TStrings.BeginUpdate;
begin
if FUpdateCount = 0 then SetUpdateState(true);
inc(FUpdateCount);
end;
Procedure TStrings.EndUpdate;
begin
If FUpdateCount>0 then
Dec(FUpdateCount);
if FUpdateCount=0 then
SetUpdateState(False);
end;
Function TStrings.Equals(TheStrings: TStrings): Boolean;
Var Runner,Nr : Longint;
begin
Result:=False;
Nr:=Self.Count;
if Nr<>TheStrings.Count then exit;
For Runner:=0 to Nr-1 do
If Strings[Runner]<>TheStrings[Runner] then exit;
Result:=True;
end;
Procedure TStrings.Exchange(Index1, Index2: Integer);
Var
Obj : TObject;
Str : String;
begin
Try
beginUpdate;
Obj:=Objects[Index1];
Str:=Strings[Index1];
Objects[Index1]:=Objects[Index2];
Strings[Index1]:=Strings[Index2];
Objects[Index2]:=Obj;
Strings[Index2]:=Str;
finally
EndUpdate;
end;
end;
Function TStrings.GetText: PChar;
begin
Result:=StrNew(Pchar(Self.Text));
end;
Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt;
begin
result:=CompareText(s1,s2);
end;
Function TStrings.IndexOf(const S: string): Integer;
begin
Result:=0;
While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1;
if Result=Count then Result:=-1;
end;
Function TStrings.IndexOfName(const Name: string): Integer;
Var
len : longint;
S : String;
begin
CheckSpecialChars;
Result:=0;
while (Result<Count) do
begin
S:=Strings[Result];
len:=pos(FNameValueSeparator,S)-1;
if (len>0) and (DoCompareText(Name,Copy(S,1,Len))=0) then
exit;
inc(result);
end;
result:=-1;
end;
Function TStrings.IndexOfObject(AObject: TObject): Integer;
begin
Result:=0;
While (Result<count) and (Objects[Result]<>AObject) do Result:=Result+1;
If Result=Count then Result:=-1;
end;
Procedure TStrings.InsertObject(Index: Integer; const S: string;
AObject: TObject);
begin
Insert (Index,S);
Objects[Index]:=AObject;
end;
Procedure TStrings.LoadFromFile(const FileName: string);
Var
TheStream : TFileStream;
begin
TheStream:=TFileStream.Create(FileName,fmOpenRead);
LoadFromStream(TheStream);
TheStream.Free;
end;
Procedure TStrings.LoadFromStream(Stream: TStream);
{
Borlands method is no good, since a pipe for
instance doesn't have a size.
So we must do it the hard way.
}
Const
BufSize = 1024;
MaxGrow = 1 shl 29;
Var
Buffer : AnsiString;
BytesRead,
BufLen,
I,BufDelta : Longint;
begin
// reread into a buffer
try
beginupdate;
Buffer:='';
BufLen:=0;
I:=1;
Repeat
BufDelta:=BufSize*I;
SetLength(Buffer,BufLen+BufDelta);
BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta);
inc(BufLen,BufDelta);
If I<MaxGrow then
I:=I shl 1;
Until BytesRead<>BufDelta;
SetLength(Buffer, BufLen-BufDelta+BytesRead);
SetTextStr(Buffer);
SetLength(Buffer,0);
finally
EndUpdate;
end;
end;
Procedure TStrings.Move(CurIndex, NewIndex: Integer);
Var
Obj : TObject;
Str : String;
begin
BeginUpdate;
Obj:=Objects[CurIndex];
Str:=Strings[CurIndex];
Delete(Curindex);
InsertObject(NewIndex,Str,Obj);
EndUpdate;
end;
Procedure TStrings.SaveToFile(const FileName: string);
Var TheStream : TFileStream;
begin
TheStream:=TFileStream.Create(FileName,fmCreate);
SaveToStream(TheStream);
TheStream.Free;
end;
Procedure TStrings.SaveToStream(Stream: TStream);
Var
S : String;
begin
S:=Text;
Stream.WriteBuffer(Pointer(S)^,Length(S));
end;
Procedure TStrings.SetText(TheText: PChar);
Var S : String;
begin
If TheText<>Nil then
S:=StrPas(TheText)
else
S:='';
SetTextStr(S);
end;
{****************************************************************************}
{* TStringList *}
{****************************************************************************}
{$if defined(VER2_0) or not defined(FPC_TESTGENERICS)}
Procedure TStringList.ExchangeItems(Index1, Index2: Integer);
Var P1,P2 : Pointer;
begin
P1:=Pointer(Flist^[Index1].FString);
P2:=Pointer(Flist^[Index1].FObject);
Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring);
Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject);
Pointer(Flist^[Index2].Fstring):=P1;
Pointer(Flist^[Index2].FObject):=P2;
end;
Procedure TStringList.Grow;
Var
NC : Integer;
begin
NC:=FCapacity;
If NC>=256 then
NC:=NC+(NC Div 4)
else if NC=0 then
NC:=4
else
NC:=NC*4;
SetCapacity(NC);
end;
Procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
var
Pivot, vL, vR: Integer;
begin
if R - L <= 1 then begin // a little bit of time saver
if L < R then
if CompareFn(Self, L, R) > 0 then
ExchangeItems(L, R);
Exit;
end;
vL := L;
vR := R;
Pivot := L + Random(R - L); // they say random is best
while vL < vR do begin
while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do
Inc(vL);
while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
Dec(vR);
ExchangeItems(vL, vR);
if Pivot = vL then // swap pivot if we just hit it from one side
Pivot := vR
else if Pivot = vR then
Pivot := vL;
end;
if Pivot - 1 >= L then
QuickSort(L, Pivot - 1, CompareFn);
if Pivot + 1 <= R then
QuickSort(Pivot + 1, R, CompareFn);
end;
Procedure TStringList.InsertItem(Index: Integer; const S: string);
begin
Changing;
If FCount=Fcapacity then Grow;
If Index<FCount then
System.Move (FList^[Index],FList^[Index+1],
(FCount-Index)*SizeOf(TStringItem));
Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
Flist^[Index].FString:=S;
Flist^[Index].Fobject:=Nil;
Inc(FCount);
Changed;
end;
Procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject);
begin
Changing;
If FCount=Fcapacity then Grow;
If Index<FCount then
System.Move (FList^[Index],FList^[Index+1],
(FCount-Index)*SizeOf(TStringItem));
Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
Flist^[Index].FString:=S;
Flist^[Index].FObject:=O;
Inc(FCount);
Changed;
end;
Procedure TStringList.SetSorted(Value: Boolean);
begin
If FSorted<>Value then
begin
If Value then sort;
FSorted:=VAlue
end;
end;
Procedure TStringList.Changed;
begin
If (FUpdateCount=0) Then
If Assigned(FOnChange) then
FOnchange(Self);
end;
Procedure TStringList.Changing;
begin
If FUpdateCount=0 then
if Assigned(FOnChanging) then
FOnchanging(Self);
end;
Function TStringList.Get(Index: Integer): string;
begin
If (Index<0) or (INdex>=Fcount) then
Error (SListIndexError,Index);
Result:=Flist^[Index].FString;
end;
Function TStringList.GetCapacity: Integer;
begin
Result:=FCapacity;
end;
Function TStringList.GetCount: Integer;
begin
Result:=FCount;
end;
Function TStringList.GetObject(Index: Integer): TObject;
begin
If (Index<0) or (INdex>=Fcount) then
Error (SListIndexError,Index);
Result:=Flist^[Index].FObject;
end;
Procedure TStringList.Put(Index: Integer; const S: string);
begin
If Sorted then
Error(SSortedListError,0);
If (Index<0) or (INdex>=Fcount) then
Error (SListIndexError,Index);
Changing;
Flist^[Index].FString:=S;
Changed;
end;
Procedure TStringList.PutObject(Index: Integer; AObject: TObject);
begin
If (Index<0) or (INdex>=Fcount) then
Error (SListIndexError,Index);
Changing;
Flist^[Index].FObject:=AObject;
Changed;
end;
Procedure TStringList.SetCapacity(NewCapacity: Integer);
Var NewList : Pointer;
MSize : Longint;
begin
If (NewCapacity<0) then
Error (SListCapacityError,NewCapacity);
If NewCapacity>FCapacity then
begin
GetMem (NewList,NewCapacity*SizeOf(TStringItem));
If NewList=Nil then
Error (SListCapacityError,NewCapacity);
If Assigned(FList) then
begin
MSize:=FCapacity*Sizeof(TStringItem);
System.Move (FList^,NewList^,MSize);
FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*WordRatio, 0);
FreeMem (Flist,MSize);
end;
Flist:=NewList;
FCapacity:=NewCapacity;
end
else if NewCapacity<FCapacity then
begin
if NewCapacity = 0 then
begin
FreeMem(FList);
FList := nil;
end else
begin
GetMem(NewList, NewCapacity * SizeOf(TStringItem));
System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
FreeMem(FList);
FList := NewList;
end;
FCapacity:=NewCapacity;
end;
end;
Procedure TStringList.SetUpdateState(Updating: Boolean);
begin
If Updating then
Changing
else
Changed
end;
destructor TStringList.Destroy;
Var I : Longint;
begin
FOnChange:=Nil;
FOnChanging:=Nil;
// This will force a dereference. Can be done better...
For I:=0 to FCount-1 do
FList^[I].FString:='';
FCount:=0;
SetCapacity(0);
Inherited destroy;
end;
Function TStringList.Add(const S: string): Integer;
begin
If Not Sorted then
Result:=FCount
else
If Find (S,Result) then
Case DUplicates of
DupIgnore : Exit;
DupError : Error(SDuplicateString,0)
end;
InsertItem (Result,S);
end;
Procedure TStringList.Clear;
Var I : longint;
begin
if FCount = 0 then Exit;
Changing;
For I:=0 to FCount-1 do
Flist^[I].FString:='';
FCount:=0;
SetCapacity(0);
Changed;
end;
Procedure TStringList.Delete(Index: Integer);
begin
If (Index<0) or (Index>=FCount) then
Error(SlistINdexError,Index);
Changing;
Flist^[Index].FString:='';
Dec(FCount);
If Index<FCount then
System.Move(Flist^[Index+1],
Flist^[Index],
(Fcount-Index)*SizeOf(TStringItem));
Changed;
end;
Procedure TStringList.Exchange(Index1, Index2: Integer);
begin
If (Index1<0) or (Index1>=FCount) then
Error(SListIndexError,Index1);
If (Index2<0) or (Index2>=FCount) then
Error(SListIndexError,Index2);
Changing;
ExchangeItems(Index1,Index2);
changed;
end;
procedure TStringList.SetCaseSensitive(b : boolean);
begin
if b<>FCaseSensitive then
begin
FCaseSensitive:=b;
if FSorted then
sort;
end;
end;
Function TStringList.DoCompareText(const s1,s2 : string) : PtrInt;
begin
if FCaseSensitive then
result:=AnsiCompareStr(s1,s2)
else
result:=AnsiCompareText(s1,s2);
end;
Function TStringList.Find(const S: string; var Index: Integer): Boolean;
var
L, R, I: Integer;
CompareRes: PtrInt;
begin
Result := false;
// Use binary search.
L := 0;
R := Count - 1;
while (L<=R) do
begin
I := L + (R - L) div 2;
CompareRes := DoCompareText(S, Flist^[I].FString);
if (CompareRes>0) then
L := I+1
else begin
R := I-1;
if (CompareRes=0) then begin
Result := true;
if (Duplicates<>dupAccept) then
L := I; // forces end of while loop
end;
end;
end;
Index := L;
end;
Function TStringList.IndexOf(const S: string): Integer;
begin
If Not Sorted then
Result:=Inherited indexOf(S)
else
// faster using binary search...
If Not Find (S,Result) then
Result:=-1;
end;
Procedure TStringList.Insert(Index: Integer; const S: string);
begin
If Sorted then
Error (SSortedListError,0)
else
If (Index<0) or (Index>FCount) then
Error (SListIndexError,Index)
else
InsertItem (Index,S);
end;
Procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
begin
If Not Sorted and (FCount>1) then
begin
Changing;
QuickSort(0,FCount-1, CompareFn);
Changed;
end;
end;
function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
begin
Result := List.DoCompareText(List.FList^[Index1].FString,
List.FList^[Index].FString);
end;
Procedure TStringList.Sort;
begin
CustomSort(@StringListAnsiCompare);
end;
{$else}
{ generics based implementation of TStringList follows }
function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
begin
Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]);
end;
constructor TStringList.Create;
begin
inherited;
FMap := TFPStrObjMap.Create;
FMap.OnPtrCompare := @MapPtrCompare;
FOnCompareText := @DefaultCompareText;
end;
destructor TStringList.Destroy;
begin
FMap.Free;
inherited;
end;
function TStringList.GetDuplicates: TDuplicates;
begin
Result := FMap.Duplicates;
end;
function TStringList.GetSorted: boolean;
begin
Result := FMap.Sorted;
end;
procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates);
begin
FMap.Duplicates := NewDuplicates;
end;
procedure TStringList.SetSorted(NewSorted: Boolean);
begin
FMap.Sorted := NewSorted;
end;
procedure TStringList.Changed;
begin
if FUpdateCount = 0 then
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TStringList.Changing;
begin
if FUpdateCount = 0 then
if Assigned(FOnChanging) then
FOnChanging(Self);
end;
function TStringList.Get(Index: Integer): string;
begin
Result := FMap.Keys[Index];
end;
function TStringList.GetCapacity: Integer;
begin
Result := FMap.Capacity;
end;
function TStringList.GetCount: Integer;
begin
Result := FMap.Count;
end;
function TStringList.GetObject(Index: Integer): TObject;
begin
Result := FMap.Data[Index];
end;
procedure TStringList.Put(Index: Integer; const S: string);
begin
Changing;
FMap.Keys[Index] := S;
Changed;
end;
procedure TStringList.PutObject(Index: Integer; AObject: TObject);
begin
Changing;
FMap.Data[Index] := AObject;
Changed;
end;
procedure TStringList.SetCapacity(NewCapacity: Integer);
begin
FMap.Capacity := NewCapacity;
end;
procedure TStringList.SetUpdateState(Updating: Boolean);
begin
if Updating then
Changing
else
Changed
end;
function TStringList.Add(const S: string): Integer;
begin
Result := FMap.Add(S);
end;
procedure TStringList.Clear;
begin
if FMap.Count = 0 then exit;
Changing;
FMap.Clear;
Changed;
end;
procedure TStringList.Delete(Index: Integer);
begin
if (Index < 0) or (Index >= FMap.Count) then
Error(SListIndexError, Index);
Changing;
FMap.Delete(Index);
Changed;
end;
procedure TStringList.Exchange(Index1, Index2: Integer);
begin
if (Index1 < 0) or (Index1 >= FMap.Count) then
Error(SListIndexError, Index1);
if (Index2 < 0) or (Index2 >= FMap.Count) then
Error(SListIndexError, Index2);
Changing;
FMap.InternalExchange(Index1, Index2);
Changed;
end;
procedure TStringList.SetCaseSensitive(NewSensitive: Boolean);
begin
if NewSensitive <> FCaseSensitive then
begin
FCaseSensitive := NewSensitive;
if Sorted then
Sort;
end;
end;
function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer;
begin
Result := FOnCompareText(string(Key1^), string(Key2^));
end;
function TStringList.DefaultCompareText(const s1, s2: string): PtrInt;
begin
if FCaseSensitive then
Result := AnsiCompareStr(s1, s2)
else
Result := AnsiCompareText(s1, s2);
end;
function TStringList.DoCompareText(const s1, s2: string): PtrInt;
begin
Result := FOnCompareText(s1, s2);
end;
function TStringList.Find(const S: string; var Index: Integer): Boolean;
begin
Result := FMap.Find(S, Index);
end;
function TStringList.IndexOf(const S: string): Integer;
begin
Result := FMap.IndexOf(S);
end;
procedure TStringList.Insert(Index: Integer; const S: string);
begin
if not Sorted and (0 <= Index) and (Index < FMap.Count) then
Changing;
FMap.InsertKey(Index, S);
Changed;
end;
procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
var
I, J, Pivot: Integer;
begin
repeat
I := L;
J := R;
Pivot := (L + R) div 2;
repeat
while CompareFn(Self, I, Pivot) < 0 do Inc(I);
while CompareFn(Self, J, Pivot) > 0 do Dec(J);
if I <= J then
begin
FMap.InternalExchange(I, J); // No check, indices are correct.
if Pivot = I then
Pivot := J
else if Pivot = J then
Pivot := I;
Inc(I);
Dec(j);
end;
until I > J;
if L < J then
QuickSort(L,J, CompareFn);
L := I;
until I >= R;
end;
procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
begin
if not Sorted and (FMap.Count > 1) then
begin
Changing;
QuickSort(0, FMap.Count-1, CompareFn);
Changed;
end;
end;
procedure TStringList.Sort;
begin
if not Sorted and (FMap.Count > 1) then
begin
Changing;
FMap.Sort;
Changed;
end;
end;
{$endif}