1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2000 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13 14{****************************************************************************} 15{* TStringsEnumerator *} 16{****************************************************************************} 17 18constructor TStringsEnumerator.Create(AStrings: TStrings); 19begin 20 inherited Create; 21 FStrings := AStrings; 22 FPosition := -1; 23end; 24 25function TStringsEnumerator.GetCurrent: String; 26begin 27 Result := FStrings[FPosition]; 28end; 29 30function TStringsEnumerator.MoveNext: Boolean; 31begin 32 Inc(FPosition); 33 Result := FPosition < FStrings.Count; 34end; 35 36{****************************************************************************} 37{* TStrings *} 38{****************************************************************************} 39 40// Function to quote text. Should move maybe to sysutils !! 41// Also, it is not clear at this point what exactly should be done. 42 43{ //!! is used to mark unsupported things. } 44 45Function QuoteString (Const S : String; Const Quote : String) : String; 46Var 47 I,J : Integer; 48begin 49 J:=0; 50 Result:=S; 51 for i:=1 to length(s) do 52 begin 53 inc(j); 54 if S[i]=Quote then 55 begin 56 System.Insert(Quote,Result,J); 57 inc(j); 58 end; 59 end; 60 Result:=Quote+Result+Quote; 61end; 62 63{ 64 For compatibility we can't add a Constructor to TSTrings to initialize 65 the special characters. Therefore we add a routine which is called whenever 66 the special chars are needed. 67} 68 69Procedure Tstrings.CheckSpecialChars; 70 71begin 72 If Not FSpecialCharsInited then 73 begin 74 FQuoteChar:='"'; 75 FDelimiter:=','; 76 FNameValueSeparator:='='; 77 FLBS:=DefaultTextLineBreakStyle; 78 FSpecialCharsInited:=true; 79 FLineBreak:=sLineBreak; 80 end; 81end; 82 83Function TStrings.GetSkipLastLineBreak : Boolean; 84 85begin 86 Result:=not TrailingLineBreak; 87end; 88 89procedure TStrings.SetSkipLastLineBreak(const AValue : Boolean); 90 91begin 92 TrailingLineBreak:=not AValue; 93end; 94 95Function TStrings.GetLBS : TTextLineBreakStyle; 96begin 97 CheckSpecialChars; 98 Result:=FLBS; 99end; 100 101Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle); 102begin 103 CheckSpecialChars; 104 FLBS:=AValue; 105end; 106 107procedure TStrings.SetDelimiter(c:Char); 108begin 109 CheckSpecialChars; 110 FDelimiter:=c; 111end; 112 113Procedure TStrings.SetEncoding(const AEncoding: TEncoding); 114begin 115 if (FEncoding<>nil) and not TEncoding.IsStandardEncoding(FEncoding) then 116 FEncoding.Free; 117 118 if TEncoding.IsStandardEncoding(AEncoding) then 119 FEncoding:=AEncoding 120 else if AEncoding<>nil then 121 FEncoding:=AEncoding.Clone 122 else 123 FEncoding:=nil; 124end; 125 126Function TStrings.GetDelimiter : Char; 127begin 128 CheckSpecialChars; 129 Result:=FDelimiter; 130end; 131 132procedure TStrings.SetLineBreak(Const S : String); 133begin 134 CheckSpecialChars; 135 FLineBreak:=S; 136end; 137 138Function TStrings.GetLineBreak : String; 139begin 140 CheckSpecialChars; 141 Result:=FLineBreak; 142end; 143 144 145procedure TStrings.SetQuoteChar(c:Char); 146begin 147 CheckSpecialChars; 148 FQuoteChar:=c; 149end; 150 151Function TStrings.GetQuoteChar :Char; 152begin 153 CheckSpecialChars; 154 Result:=FQuoteChar; 155end; 156 157procedure TStrings.SetNameValueSeparator(c:Char); 158begin 159 CheckSpecialChars; 160 FNameValueSeparator:=c; 161end; 162 163 164 165Function TStrings.GetNameValueSeparator :Char; 166begin 167 CheckSpecialChars; 168 Result:=FNameValueSeparator; 169end; 170 171 172function TStrings.GetCommaText: string; 173 174Var 175 C1,C2 : Char; 176 FSD : Boolean; 177 178begin 179 CheckSpecialChars; 180 FSD:=StrictDelimiter; 181 C1:=Delimiter; 182 C2:=QuoteChar; 183 Delimiter:=','; 184 QuoteChar:='"'; 185 StrictDelimiter:=False; 186 Try 187 Result:=GetDelimitedText; 188 Finally 189 Delimiter:=C1; 190 QuoteChar:=C2; 191 StrictDelimiter:=FSD; 192 end; 193end; 194 195function TStrings.GetLineBreakCharLBS: string; 196begin 197 CheckSpecialChars; 198 if FLineBreak<>sLineBreak then 199 Result:=FLineBreak 200 else 201 Case FLBS of 202 tlbsLF : Result:=#10; 203 tlbsCRLF : Result:=#13#10; 204 tlbsCR : Result:=#13; 205 end; 206end; 207 208function TStrings.GetMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction; 209begin 210 CheckSpecialChars; 211 Result:=FMissingNameValueSeparatorAction; 212end; 213 214 215Function TStrings.GetDelimitedText: string; 216 217Var 218 I : integer; 219 p : pchar; 220 BreakChars : set of char; 221 S : String; 222 doQuote : Boolean; 223 224begin 225 CheckSpecialChars; 226 result:=''; 227 if StrictDelimiter then 228 BreakChars:=[#0,QuoteChar,Delimiter] 229 else 230 BreakChars:=[#0..' ',QuoteChar,Delimiter]; 231 // Check for break characters and quote if required. 232 For i:=0 to count-1 do 233 begin 234 S:=Strings[i]; 235 doQuote:=FAlwaysQuote; 236 If not DoQuote then 237 begin 238 p:=pchar(S); 239 //Quote strings that include BreakChars: 240 while not(p^ in BreakChars) do 241 inc(p); 242 DoQuote:=(p<>pchar(S)+length(S)); 243 end; 244 if DoQuote and (QuoteChar<>#0) then 245 Result:=Result+QuoteString(S,QuoteChar) 246 else 247 Result:=Result+S; 248 if I<Count-1 then 249 Result:=Result+Delimiter; 250 end; 251 // Quote empty string: 252 If (Length(Result)=0) and (Count=1) and (QuoteChar<>#0) then 253 Result:=QuoteChar+QuoteChar; 254end; 255 256procedure TStrings.GetNameValue(Index : Integer; Out AName,AValue : String); 257 258Var L : longint; 259 260begin 261 aName:=''; 262 CheckSpecialChars; 263 AValue:=Strings[Index]; 264 L:=Pos(FNameValueSeparator,AValue); 265 If L<>0 then 266 begin 267 AName:=Copy(AValue,1,L-1); 268 System.Delete(AValue,1,L); 269 end 270 else 271 case FMissingNameValueSeparatorAction of 272 mnvaValue : ; 273 mnvaName : 274 begin 275 aName:=aValue; 276 aValue:=''; 277 end; 278 mnvaEmpty : 279 aValue:=''; 280 mnvaError : 281 Raise EStringListError.CreateFmt(SErrNoNameValuePairAt,[Index]); 282 end; 283end; 284 285function TStrings.ExtractName(const s:String):String; 286var 287 L: Longint; 288begin 289 CheckSpecialChars; 290 L:=Pos(FNameValueSeparator,S); 291 If L<>0 then 292 Result:=Copy(S,1,L-1) 293 else 294 Result:=''; 295end; 296 297 298procedure TStrings.Filter(aFilter: TStringsFilterMethod; aList: TStrings); 299 300var 301 S : string; 302 303begin 304 for S in self do 305 if aFilter(S) then 306 aList.Add(S); 307end; 308 309 310procedure TStrings.ForEach(aCallback: TStringsForeachMethod); 311 312var 313 S : String; 314 315begin 316 for S in self do 317 aCallBack(S); 318end; 319 320 321procedure TStrings.ForEach(aCallback: TStringsForeachMethodEx); 322 323var 324 i: integer; 325 326begin 327 for i:=0 to Count-1 do 328 aCallBack(Strings[i],i); 329end; 330 331 332procedure TStrings.ForEach(aCallback: TStringsForeachMethodExObj); 333 334var 335 i: integer; 336 337begin 338 for i:=0 to Count-1 do 339 aCallback(Strings[i],i,Objects[i]); 340end; 341 342 343function TStrings.Filter(aFilter: TStringsFilterMethod): TStrings; 344 345begin 346 Result:=TStringsClass(Self.ClassType).Create; 347 try 348 Filter(aFilter,Result); 349 except 350 FreeAndNil(Result); 351 Raise; 352 end; 353end; 354 355procedure TStrings.Fill(const aValue: String; aStart, aEnd: Integer); 356var 357 i: integer; 358begin 359 if aEnd<0 then 360 aEnd:=Self.Count+aEnd; 361 if aEnd>=Count then 362 aEnd:=Count-1; 363 for i:=aStart to aEnd do 364 Strings[i]:=aValue; 365end; 366 367 368Procedure TStrings.Map(aMap: TStringsMapMethod; aList : TStrings); 369 370Var 371 S : String; 372 373begin 374 For S in self do 375 aList.Add(aMap(S)); 376end; 377 378 379Function TStrings.Map(aMap: TStringsMapMethod) : TStrings; 380 381begin 382 Result:=TStringsClass(Self.ClassType).Create; 383 try 384 Map(aMap,Result); 385 except 386 FreeAndNil(Result); 387 Raise; 388 end; 389end; 390 391 392function TStrings.Reduce(aReduceMethod: TStringsReduceMethod; const startingValue: string): string; 393 394var 395 S : String; 396 397begin 398 Result:=startingValue; 399 for S in self do 400 Result:=aReduceMethod(Result, S); 401end; 402 403 404Function TStrings.Reverse : TStrings; 405 406begin 407 Result:=TStringsClass(Self.ClassType).Create; 408 try 409 Reverse(Result); 410 except 411 FreeAndNil(Result); 412 Raise; 413 end; 414end; 415 416 417Procedure TStrings.Reverse(aList : TStrings); 418 419Var 420 I : Integer; 421 422begin 423 for I:=Count-1 downto 0 do 424 aList.Add(Strings[i]); 425end; 426 427 428Procedure TStrings.Slice(fromIndex: integer; aList : TStrings); 429 430var 431 i: integer; 432 433begin 434 for i:=fromIndex to Count-1 do 435 aList.Add(Self[i]); 436end; 437 438Function TStrings.Slice(fromIndex: integer) : TStrings; 439 440begin 441 Result:=TStringsClass(Self.ClassType).Create; 442 try 443 Slice(FromIndex,Result); 444 except 445 FreeAndNil(Result); 446 Raise; 447 end; 448end; 449 450function TStrings.GetName(Index: Integer): string; 451 452Var 453 V : String; 454 455begin 456 GetNameValue(Index,Result,V); 457end; 458 459function TStrings.GetStrictDelimiter: Boolean; 460begin 461 Result:=soStrictDelimiter in FOptions; 462end; 463 464function TStrings.GetTrailingLineBreak: Boolean; 465begin 466 Result:=soTrailingLineBreak in FOptions; 467end; 468 469function TStrings.GetUseLocale: Boolean; 470begin 471 Result:=soUseLocale in FOptions; 472end; 473 474function TStrings.GetWriteBOM: Boolean; 475begin 476 Result:=soWriteBOM in FOptions; 477end; 478 479Function TStrings.GetValue(const Name: string): string; 480 481Var 482 L : longint; 483 N : String; 484 485begin 486 Result:=''; 487 L:=IndexOfName(Name); 488 If L<>-1 then 489 GetNameValue(L,N,Result); 490end; 491 492Function TStrings.GetValueFromIndex(Index: Integer): string; 493 494Var 495 N : String; 496 497begin 498 GetNameValue(Index,N,Result); 499end; 500 501Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string); 502 503begin 504 If (Value='') then 505 Delete(Index) 506 else 507 begin 508 If (Index<0) then 509 Index:=Add(''); 510 CheckSpecialChars; 511 Strings[Index]:=GetName(Index)+FNameValueSeparator+Value; 512 end; 513end; 514 515procedure TStrings.ReadData(Reader: TReader); 516begin 517 Reader.ReadListBegin; 518 BeginUpdate; 519 try 520 Clear; 521 while not Reader.EndOfList do 522 Add(Reader.ReadString); 523 finally 524 EndUpdate; 525 end; 526 Reader.ReadListEnd; 527end; 528 529 530Procedure TStrings.SetDelimitedText(const AValue: string); 531 532begin 533 CheckSpecialChars; 534 DoSetDelimitedText(aValue,True,StrictDelimiter,FQuoteChar,FDelimiter); 535end; 536 537Procedure TStrings.DoSetDelimitedText(const AValue: string; DoClear,aStrictDelimiter : Boolean; aQuoteChar,aDelimiter : Char); 538 539var 540 len,i,j: SizeInt; 541 aNotFirst:boolean; 542 543 Procedure AddQuoted; 544 545 begin 546 Add(StringReplace(Copy(AValue,i+1,j-i-1),aQuoteChar+aQuoteChar,aQuoteChar, [rfReplaceAll])); 547 end; 548 549 Function CheckQuoted : Boolean; 550 { Paraphrased from Delphi XE2 help: 551 Strings must be separated by Delimiter characters or spaces. 552 They may be enclosed in QuoteChars. 553 QuoteChars in the string must be repeated to distinguish them from the QuoteChars enclosing the string. 554 } 555 556 begin 557 Result:=(AValue[i]=aQuoteChar) and (aQuoteChar<>#0); 558 If Not Result then 559 exit; 560 // next string is quoted 561 j:=i+1; 562 while (j<=len) and 563 ((AValue[j]<>aQuoteChar) or 564 ((j+1<=len) and (AValue[j+1]=aQuoteChar))) do 565 begin 566 if (j<=len) and (AValue[j]=aQuoteChar) then 567 inc(j,2) 568 else 569 inc(j); 570 end; 571 AddQuoted; 572 i:=j+1; 573 end; 574 575 Procedure MaybeSkipSpaces; inline; 576 577 begin 578 if Not aStrictDelimiter then 579 while (i<=len) and (Ord(AValue[i])<=Ord(' ')) do 580 inc(i); 581 end; 582 583begin 584 BeginUpdate; 585 i:=1; 586 j:=1; 587 aNotFirst:=false; 588 try 589 if DoClear then 590 Clear; 591 len:=length(AValue); 592 while i<=len do 593 begin 594 // skip delimiter 595 if aNotFirst and (i<=len) and (AValue[i]=aDelimiter) then 596 inc(i); 597 MaybeSkipSpaces; 598 // read next string 599 if i>len then 600 begin 601 if aNotFirst then Add(''); 602 end 603 else 604 begin 605 // next string is quoted 606 if not CheckQuoted then 607 begin 608 // next string is not quoted; read until control character/space/delimiter 609 j:=i; 610 while (j<=len) and 611 (aStrictDelimiter or (Ord(AValue[j])>Ord(' '))) and 612 (AValue[j]<>aDelimiter) do 613 inc(j); 614 Add( Copy(AValue,i,j-i)); 615 i:=j; 616 end; 617 end; 618 MaybeSkipSpaces; 619 aNotFirst:=true; 620 end; // While I<=Len 621 finally 622 EndUpdate; 623 end; 624end; 625 626Procedure TStrings.SetCommaText(const Value: string); 627 628begin 629 CheckSpecialChars; 630 DoSetDelimitedText(Value,True,StrictDelimiter,'"',','); 631end; 632 633procedure TStrings.SetMissingNameValueSeparatorAction(AValue: TMissingNameValueSeparatorAction); 634begin 635 CheckSpecialChars; 636 FMissingNameValueSeparatorAction:=aValue; 637end; 638 639 640Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter); 641 642begin 643end; 644 645procedure TStrings.SetStrictDelimiter(AValue: Boolean); 646begin 647 if AValue then 648 Include(FOptions,soStrictDelimiter) 649 else 650 Exclude(FOptions,soStrictDelimiter); 651end; 652 653procedure TStrings.SetTrailingLineBreak(AValue: Boolean); 654begin 655 if AValue then 656 Include(FOptions,soTrailingLineBreak) 657 else 658 Exclude(FOptions,soTrailingLineBreak); 659end; 660 661procedure TStrings.SetUseLocale(AValue: Boolean); 662begin 663 if AValue then 664 Include(FOptions,soUseLocale) 665 else 666 Exclude(FOptions,soUseLocale); 667end; 668 669 670procedure TStrings.SetWriteBOM(AValue: Boolean); 671begin 672 if AValue then 673 Include(FOptions,soWriteBOM) 674 else 675 Exclude(FOptions,soWriteBOM); 676end; 677 678 679 680Procedure TStrings.SetDefaultEncoding(const ADefaultEncoding: TEncoding); 681begin 682 if (FDefaultEncoding<>nil) and not TEncoding.IsStandardEncoding(FDefaultEncoding) then 683 FDefaultEncoding.Free; 684 685 if TEncoding.IsStandardEncoding(ADefaultEncoding) then 686 FDefaultEncoding:=ADefaultEncoding 687 else if ADefaultEncoding<>nil then 688 FDefaultEncoding:=ADefaultEncoding.Clone 689 else 690 FDefaultEncoding:=TEncoding.Default; 691end; 692 693 694 695Procedure TStrings.SetValue(const Name, Value: string); 696 697Var L : longint; 698 699begin 700 CheckSpecialChars; 701 L:=IndexOfName(Name); 702 if L=-1 then 703 Add (Name+FNameValueSeparator+Value) 704 else 705 Strings[L]:=Name+FNameValueSeparator+value; 706end; 707 708 709 710procedure TStrings.WriteData(Writer: TWriter); 711var 712 i: Integer; 713begin 714 Writer.WriteListBegin; 715 for i := 0 to Count - 1 do 716 Writer.WriteString(Strings[i]); 717 Writer.WriteListEnd; 718end; 719 720 721 722function TStrings.CompareStrings(const s1,s2 : string) : Integer; 723begin 724 Result := DoCompareText(s1, s2); 725end; 726 727 728 729procedure TStrings.DefineProperties(Filer: TFiler); 730var 731 HasData: Boolean; 732begin 733 if Assigned(Filer.Ancestor) then 734 // Only serialize if string list is different from ancestor 735 if Filer.Ancestor.InheritsFrom(TStrings) then 736 HasData := not Equals(TStrings(Filer.Ancestor)) 737 else 738 HasData := True 739 else 740 HasData := Count > 0; 741 Filer.DefineProperty('Strings', @ReadData, @WriteData, HasData); 742end; 743 744 745Procedure TStrings.Error(const Msg: string; Data: Integer); 746begin 747 Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame); 748end; 749 750 751Procedure TStrings.Error(const Msg: pstring; Data: Integer); 752begin 753 Raise EStringListError.CreateFmt(Msg^,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame); 754end; 755 756 757Function TStrings.GetCapacity: Integer; 758 759begin 760 Result:=Count; 761end; 762 763 764 765Function TStrings.GetObject(Index: Integer): TObject; 766 767begin 768 Result:=Nil; 769end; 770 771 772 773Function TStrings.GetTextStr: string; 774 775Var P : Pchar; 776 I,L,NLS : SizeInt; 777 S,NL : String; 778 779begin 780 NL:=GetLineBreakCharLBS; 781 // Determine needed place 782 L:=0; 783 NLS:=Length(NL); 784 For I:=0 to count-1 do 785 L:=L+Length(Strings[I])+NLS; 786 if SkipLastLineBreak then 787 Dec(L,NLS); 788 Setlength(Result,L); 789 P:=Pointer(Result); 790 For i:=0 To count-1 do 791 begin 792 S:=Strings[I]; 793 L:=Length(S); 794 if L<>0 then 795 System.Move(Pointer(S)^,P^,L); 796 P:=P+L; 797 if (I<Count-1) or Not SkipLastLineBreak then 798 For L:=1 to NLS do 799 begin 800 P^:=NL[L]; 801 inc(P); 802 end; 803 end; 804end; 805 806 807 808Procedure TStrings.Put(Index: Integer; const S: string); 809 810Var Obj : TObject; 811 812begin 813 Obj:=Objects[Index]; 814 Delete(Index); 815 InsertObject(Index,S,Obj); 816end; 817 818 819 820Procedure TStrings.PutObject(Index: Integer; AObject: TObject); 821 822begin 823 // Empty. 824end; 825 826 827 828Procedure TStrings.SetCapacity(NewCapacity: Integer); 829 830begin 831 // Empty. 832end; 833 834Class Function TStrings.GetNextLine (Const Value : String; Var S : String; Var P : SizeInt) : Boolean; 835 836var 837 LengthOfValue: SizeInt; 838 StartPos, FuturePos: SizeInt; 839 840begin 841 LengthOfValue := Length(Value); 842 StartPos := P; 843 if (StartPos <= 0) or (StartPos > LengthOfValue) then // True for LengthOfValue <= 0 844 begin 845 S := ''; 846 Exit(False); 847 end; 848 FuturePos := StartPos; 849 while (FuturePos <= LengthOfValue) and not (Value[FuturePos] in [#10, #13]) do 850 Inc(FuturePos); 851 // If we use S := Copy(Value, StartPos, FuturePos - StartPos); then compiler 852 // generate TempS := Copy(...); S := TempS to eliminate side effects and 853 // implicit "try finally" for TempS finalization 854 // When we use SetString then no TempS, no try finally generated, 855 // but we must check case when Value and S is same (side effects) 856 if Pointer(S) = Pointer(Value) then 857 System.Delete(S, FuturePos, High(FuturePos)) 858 else 859 begin 860 SetString(S, @Value[StartPos], FuturePos - StartPos); 861 if (FuturePos <= LengthOfValue) and (Value[FuturePos] = #13) then 862 Inc(FuturePos); 863 if (FuturePos <= LengthOfValue) and (Value[FuturePos] = #10) then 864 Inc(FuturePos); 865 end; 866 P := FuturePos; 867 Result := True; 868end; 869 870Function TStrings.GetNextLineBreak (Const Value : String; Var S : String; Var P : SizeInt) : Boolean; 871 872var 873 StartPos, FuturePos: SizeInt; 874 875begin 876 StartPos := P; 877 if (StartPos <= 0) or (StartPos > Length(Value)) then // True for Length <= 0 878 begin 879 S := ''; 880 Exit(False); 881 end; 882 FuturePos := Pos(FLineBreak, Value, StartPos); // Use PosEx in old RTL 883 // Why we don't use Copy but use SetString read in GetNextLine 884 if FuturePos = 0 then // No line breaks 885 begin 886 FuturePos := Length(Value) + 1; 887 if Pointer(S) = Pointer(Value) then 888 // Nothing to do 889 else 890 SetString(S, @Value[StartPos], FuturePos - StartPos) 891 end 892 else 893 if Pointer(S) = Pointer(Value) then 894 System.Delete(S, FuturePos, High(FuturePos)) 895 else 896 begin 897 SetString(S, @Value[StartPos], FuturePos - StartPos); 898 Inc(FuturePos, Length(FLineBreak)); 899 end; 900 P := FuturePos; 901 Result := True; 902end; 903 904{$IF (SizeOf(Integer) < SizeOf(SizeInt)) } 905class function TStrings.GetNextLine(const Value: string; var S: string; var P: Integer) : Boolean; 906var 907 LP: SizeInt; 908begin 909 LP := P; 910 Result := GetNextLine(Value, S, LP); 911 P := LP; 912end; 913 914function TStrings.GetNextLineBreak(const Value: string; var S: string; var P: Integer) : Boolean; 915var 916 LP: SizeInt; 917begin 918 LP := P; 919 Result := GetNextLineBreak(Value, S, LP); 920 P := LP; 921end; 922{$IFEND} 923 924Procedure TStrings.DoSetTextStr(const Value: string; DoClear : Boolean); 925 926Var 927 S : String; 928 P : SizeInt; 929 930begin 931 Try 932 beginUpdate; 933 if DoClear then 934 Clear; 935 P:=1; 936 if FLineBreak=sLineBreak then 937 begin 938 While GetNextLine (Value,S,P) do 939 Add(S) 940 end 941 else 942 While GetNextLineBreak (Value,S,P) do 943 Add(S); 944 finally 945 EndUpdate; 946 end; 947end; 948 949Procedure TStrings.SetTextStr(const Value: string); 950 951begin 952 CheckSpecialChars; 953 DoSetTextStr(Value,True); 954end; 955 956Procedure TStrings.AddText(const S: string); 957 958begin 959 CheckSpecialChars; 960 DoSetTextStr(S,False); 961end; 962 963procedure TStrings.AddCommaText(const S: String); 964 965begin 966 DoSetDelimitedText(S,False,StrictDelimiter,'"',','); 967end; 968 969procedure TStrings.AddDelimitedText(const S: String; ADelimiter: Char; AStrictDelimiter: Boolean); 970 971begin 972 CheckSpecialChars; 973 DoSetDelimitedText(S,False,AStrictDelimiter,FQuoteChar,ADelimiter); 974end; 975 976procedure TStrings.AddDelimitedText(const S: String); 977begin 978 CheckSpecialChars; 979 DoSetDelimitedText(S,False,StrictDelimiter,FQuoteChar,FDelimiter); 980end; 981 982Procedure TStrings.SetUpdateState(Updating: Boolean); 983 984begin 985 FPONotifyObservers(Self,ooChange,Nil); 986end; 987 988 989destructor TSTrings.Destroy; 990 991begin 992 if (FEncoding<>nil) and not TEncoding.IsStandardEncoding(FEncoding) then 993 FreeAndNil(FEncoding); 994 if (FDefaultEncoding<>nil) and not TEncoding.IsStandardEncoding(FDefaultEncoding) then 995 FreeAndNil(FDefaultEncoding); 996 inherited destroy; 997end; 998 999function TStrings.ToObjectArray: TObjectDynArray; 1000 1001begin 1002 Result:=ToObjectArray(0,Count-1); 1003end; 1004 1005function TStrings.ToObjectArray(aStart,aEnd : Integer): TObjectDynArray; 1006Var 1007 I : Integer; 1008 1009begin 1010 Result:=Nil; 1011 if aStart>aEnd then exit; 1012 SetLength(Result,aEnd-aStart+1); 1013 For I:=aStart to aEnd do 1014 Result[i-aStart]:=Objects[i]; 1015end; 1016 1017function TStrings.ToStringArray: TStringDynArray; 1018 1019begin 1020 Result:=ToStringArray(0,Count-1); 1021end; 1022 1023function TStrings.ToStringArray(aStart,aEnd : Integer): TStringDynArray; 1024 1025Var 1026 I : Integer; 1027 1028begin 1029 Result:=Nil; 1030 if aStart>aEnd then exit; 1031 SetLength(Result,aEnd-aStart+1); 1032 For I:=aStart to aEnd do 1033 Result[i-aStart]:=Strings[i]; 1034end; 1035 1036 1037constructor TStrings.Create; 1038begin 1039 inherited Create; 1040 FDefaultEncoding:=TEncoding.Default; 1041 FEncoding:=nil; 1042 FOptions := [soTrailingLineBreak,soUseLocale,soPreserveBOM]; 1043 FAlwaysQuote:=False; 1044end; 1045 1046Function TStrings.Add(const S: string): Integer; 1047 1048begin 1049 Result:=Count; 1050 Insert (Count,S); 1051end; 1052 1053function TStrings.Add(const Fmt : string; const Args : Array of const): Integer; 1054 1055begin 1056 Result:=Add(Format(Fmt,Args)); 1057end; 1058 1059 1060Function TStrings.AddObject(const S: string; AObject: TObject): Integer; 1061 1062begin 1063 Result:=Add(S); 1064 Objects[result]:=AObject; 1065end; 1066 1067function TStrings.AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer; 1068 1069begin 1070 Result:=AddObject(Format(Fmt,Args),AObject); 1071end; 1072 1073function TStrings.AddPair(const AName, AValue: string): TStrings; 1074begin 1075 Result:=AddPair(AName,AValue,Nil); 1076end; 1077 1078function TStrings.AddPair(const AName, AValue: string; AObject: TObject): TStrings; 1079begin 1080 Result := Self; 1081 AddObject(Concat(AName, NameValueSeparator, AValue), AObject); 1082end; 1083 1084Procedure TStrings.Append(const S: string); 1085 1086begin 1087 Add (S); 1088end; 1089 1090 1091 1092Procedure TStrings.AddStrings(TheStrings: TStrings; ClearFirst : Boolean); 1093 1094Var Runner : longint; 1095begin 1096 beginupdate; 1097 try 1098 if ClearFirst then 1099 Clear; 1100 if Count + TheStrings.Count > Capacity then 1101 Capacity := Count + TheStrings.Count; 1102 For Runner:=0 to TheStrings.Count-1 do 1103 self.AddObject (Thestrings[Runner],TheStrings.Objects[Runner]); 1104 finally 1105 EndUpdate; 1106 end; 1107end; 1108 1109Procedure TStrings.AddStrings(TheStrings: TStrings); 1110 1111begin 1112 AddStrings(TheStrings, False); 1113end; 1114 1115Procedure TStrings.AddStrings(const TheStrings: array of string); 1116 1117begin 1118 AddStrings(TheStrings, False); 1119end; 1120 1121Procedure TStrings.AddStrings(const TheStrings: array of string; ClearFirst : Boolean); 1122 1123Var Runner : longint; 1124begin 1125 beginupdate; 1126 try 1127 if ClearFirst then 1128 Clear; 1129 if Count + High(TheStrings)+1 > Capacity then 1130 Capacity := Count + High(TheStrings)+1; 1131 For Runner:=Low(TheStrings) to High(TheStrings) do 1132 self.Add(Thestrings[Runner]); 1133 finally 1134 EndUpdate; 1135 end; 1136end; 1137 1138procedure TStrings.SetStrings(TheStrings: TStrings); 1139 1140begin 1141 AddStrings(TheStrings,True); 1142end; 1143 1144procedure TStrings.SetStrings(TheStrings: array of string); 1145 1146begin 1147 AddStrings(TheStrings,True); 1148end; 1149 1150Procedure TStrings.Assign(Source: TPersistent); 1151 1152Var 1153 S : TStrings; 1154 1155begin 1156 If Source is TStrings then 1157 begin 1158 S:=TStrings(Source); 1159 BeginUpdate; 1160 Try 1161 clear; 1162 FSpecialCharsInited:=S.FSpecialCharsInited; 1163 FQuoteChar:=S.FQuoteChar; 1164 FDelimiter:=S.FDelimiter; 1165 FNameValueSeparator:=S.FNameValueSeparator; 1166 FLBS:=S.FLBS; 1167 FLineBreak:=S.FLineBreak; 1168 FOptions:=S.FOptions; 1169 DefaultEncoding:=S.DefaultEncoding; 1170 SetEncoding(S.Encoding); 1171 AddStrings(S); 1172 finally 1173 EndUpdate; 1174 end; 1175 end 1176 else 1177 Inherited Assign(Source); 1178end; 1179 1180 1181 1182Procedure TStrings.BeginUpdate; 1183 1184begin 1185 if FUpdateCount = 0 then SetUpdateState(true); 1186 inc(FUpdateCount); 1187end; 1188 1189 1190 1191Procedure TStrings.EndUpdate; 1192 1193begin 1194 If FUpdateCount>0 then 1195 Dec(FUpdateCount); 1196 if FUpdateCount=0 then 1197 SetUpdateState(False); 1198end; 1199 1200 1201 1202Function TStrings.Equals(Obj: TObject): Boolean; 1203 1204begin 1205 if Obj is TStrings then 1206 Result := Equals(TStrings(Obj)) 1207 else 1208 Result := inherited Equals(Obj); 1209end; 1210 1211 1212 1213Function TStrings.Equals(TheStrings: TStrings): Boolean; 1214 1215Var Runner,Nr : Longint; 1216 1217begin 1218 Result:=False; 1219 Nr:=Self.Count; 1220 if Nr<>TheStrings.Count then exit; 1221 For Runner:=0 to Nr-1 do 1222 If Strings[Runner]<>TheStrings[Runner] then exit; 1223 Result:=True; 1224end; 1225 1226 1227 1228Procedure TStrings.Exchange(Index1, Index2: Integer); 1229 1230Var 1231 Obj : TObject; 1232 Str : String; 1233 1234begin 1235 beginUpdate; 1236 Try 1237 Obj:=Objects[Index1]; 1238 Str:=Strings[Index1]; 1239 Objects[Index1]:=Objects[Index2]; 1240 Strings[Index1]:=Strings[Index2]; 1241 Objects[Index2]:=Obj; 1242 Strings[Index2]:=Str; 1243 finally 1244 EndUpdate; 1245 end; 1246end; 1247 1248 1249function TStrings.GetEnumerator: TStringsEnumerator; 1250begin 1251 Result:=TStringsEnumerator.Create(Self); 1252end; 1253 1254 1255Function TStrings.GetText: PChar; 1256begin 1257 Result:=StrNew(Pchar(Self.Text)); 1258end; 1259 1260 1261Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt; 1262 begin 1263 if UseLocale then 1264 result:=AnsiCompareText(s1,s2) 1265 else 1266 result:=CompareText(s1,s2); 1267 end; 1268 1269 1270Function TStrings.IndexOf(const S: string): Integer; 1271begin 1272 Result:=0; 1273 While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1; 1274 if Result=Count then Result:=-1; 1275end; 1276 1277function TStrings.IndexOf(const S: string; aStart: Integer): Integer; 1278begin 1279 if aStart<0 then 1280 begin 1281 aStart:=Count+aStart; 1282 if aStart<0 then 1283 aStart:=0; 1284 end; 1285 Result:=aStart; 1286 While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1; 1287 if Result=Count then Result:=-1; 1288end; 1289 1290 1291Function TStrings.IndexOfName(const Name: string): Integer; 1292Var 1293 len : longint; 1294 S : String; 1295begin 1296 CheckSpecialChars; 1297 Result:=0; 1298 while (Result<Count) do 1299 begin 1300 S:=Strings[Result]; 1301 len:=pos(FNameValueSeparator,S)-1; 1302 if (len>=0) and (DoCompareText(Name,Copy(S,1,Len))=0) then 1303 exit; 1304 inc(result); 1305 end; 1306 result:=-1; 1307end; 1308 1309 1310Function TStrings.IndexOfObject(AObject: TObject): Integer; 1311begin 1312 Result:=0; 1313 While (Result<count) and (Objects[Result]<>AObject) do Result:=Result+1; 1314 If Result=Count then Result:=-1; 1315end; 1316 1317 1318Procedure TStrings.InsertObject(Index: Integer; const S: string; 1319 AObject: TObject); 1320 1321begin 1322 Insert (Index,S); 1323 Objects[Index]:=AObject; 1324end; 1325 1326function TStrings.LastIndexOf(const S: string): Integer; 1327 1328begin 1329 Result:=LastIndexOf(S,Count-1); 1330end; 1331 1332function TStrings.LastIndexOf(const S: string; aStart : Integer): Integer; 1333begin 1334 if aStart<0 then 1335 begin 1336 aStart:=Count+aStart; 1337 if aStart<0 then 1338 aStart:=0; 1339 end; 1340 Result:=aStart; 1341 if Result>=Count-1 then 1342 Result:=Count-1; 1343 While (Result>=0) and (DoCompareText(Strings[Result],S)<>0) do 1344 Result:=Result-1; 1345end; 1346 1347Procedure TStrings.LoadFromFile(const FileName: string); 1348 1349begin 1350 LoadFromFile(FileName,False) 1351end; 1352 1353Procedure TStrings.LoadFromFile(const FileName: string; IgnoreEncoding : Boolean); 1354Var 1355 TheStream : TFileStream; 1356begin 1357 TheStream:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite); 1358 try 1359 LoadFromStream(TheStream, IgnoreEncoding); 1360 finally 1361 TheStream.Free; 1362 end; 1363end; 1364 1365 1366 1367Procedure TStrings.LoadFromFile(const FileName: string; AEncoding: TEncoding); 1368Var 1369 TheStream : TFileStream; 1370begin 1371 TheStream:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite); 1372 try 1373 LoadFromStream(TheStream,AEncoding); 1374 finally 1375 TheStream.Free; 1376 end; 1377end; 1378 1379Procedure TStrings.LoadFromStream(Stream: TStream); 1380 1381begin 1382 LoadFromStream(Stream,False); 1383end; 1384 1385Const 1386 LoadBufSize = 1024; 1387 LoadMaxGrow = MaxInt Div 2; 1388 1389Procedure TStrings.LoadFromStream(Stream: TStream; IgnoreEncoding : Boolean); 1390{ 1391 Borlands method is no good, since a pipe for 1392 instance doesn't have a size. 1393 So we must do it the hard way. 1394} 1395 1396Var 1397 Buffer : AnsiString; 1398 BufLen : SizeInt; 1399 BytesRead, I, BufDelta : Longint; 1400 1401begin 1402 if not IgnoreEncoding then 1403 begin 1404 LoadFromStream(Stream,Nil); 1405 Exit; 1406 end; 1407 // reread into a buffer 1408 beginupdate; 1409 try 1410 Buffer:=''; 1411 BufLen:=0; 1412 I:=1; 1413 Repeat 1414 BufDelta:=LoadBufSize*I; 1415 SetLength(Buffer,BufLen+BufDelta); 1416 BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta); 1417 inc(BufLen,BufDelta); 1418 If I<LoadMaxGrow then 1419 I:=I shl 1; 1420 Until BytesRead<>BufDelta; 1421 SetLength(Buffer, BufLen-BufDelta+BytesRead); 1422 SetTextStr(Buffer); 1423 SetLength(Buffer,0); 1424 finally 1425 EndUpdate; 1426 end; 1427 if soPreserveBOM in FOptions then 1428 WriteBOM:=False; 1429end; 1430 1431 1432Procedure TStrings.LoadFromStream(Stream: TStream; AEncoding: TEncoding); 1433{ 1434 Borlands method is no good, since a pipe for 1435 instance doesn't have a size. 1436 So we must do it the hard way. 1437} 1438 1439Var 1440 Buffer : TBytes; 1441 T : string; 1442 BufLen : SizeInt; 1443 BytesRead, I, BufDelta, PreambleLength : Longint; 1444 1445begin 1446 // reread into a buffer 1447 beginupdate; 1448 try 1449 SetLength(Buffer,0); 1450 BufLen:=0; 1451 I:=1; 1452 Repeat 1453 BufDelta:=LoadBufSize*I; 1454 SetLength(Buffer,BufLen+BufDelta); 1455 BytesRead:=Stream.Read(Buffer[BufLen],BufDelta); 1456 inc(BufLen,BufDelta); 1457 If I<LoadMaxGrow then 1458 I:=I shl 1; 1459 Until BytesRead<>BufDelta; 1460 SetLength(Buffer,BufLen-BufDelta+BytesRead); 1461 PreambleLength:=TEncoding.GetBufferEncoding(Buffer,AEncoding,FDefaultEncoding); 1462 T:=AEncoding.GetAnsiString(Buffer,PreambleLength,Length(Buffer)-PreambleLength); 1463 if soPreserveBOM in FOptions then 1464 WriteBOM:=PreambleLength>0; 1465 SetEncoding(AEncoding); 1466 SetLength(Buffer,0); 1467 SetTextStr(T); 1468 finally 1469 EndUpdate; 1470 end; 1471end; 1472 1473 1474Procedure TStrings.Move(CurIndex, NewIndex: Integer); 1475Var 1476 Obj : TObject; 1477 Str : String; 1478begin 1479 BeginUpdate; 1480 Try 1481 Obj:=Objects[CurIndex]; 1482 Str:=Strings[CurIndex]; 1483 Objects[CurIndex]:=Nil; // Prevent Delete from freeing. 1484 Delete(Curindex); 1485 InsertObject(NewIndex,Str,Obj); 1486 finally 1487 EndUpdate; 1488 end; 1489end; 1490 1491function TStrings.Pop: string; 1492 1493var 1494 C : Integer; 1495 1496begin 1497 Result:=''; 1498 C:=Count-1; 1499 if (C>=0) then 1500 begin 1501 Result:=Strings[C]; 1502 Delete(C); 1503 end; 1504end; 1505 1506function TStrings.Shift: String; 1507 1508begin 1509 Result:=''; 1510 if (Count > 0) then 1511 begin 1512 Result:=Strings[0]; 1513 Delete(0); 1514 end; 1515end; 1516 1517Procedure TStrings.SaveToFile(const FileName: string); 1518 1519Var TheStream : TFileStream; 1520 1521begin 1522 TheStream:=TFileStream.Create(FileName,fmCreate); 1523 try 1524 SaveToStream(TheStream); 1525 finally 1526 TheStream.Free; 1527 end; 1528end; 1529 1530 1531 1532Procedure TStrings.SaveToFile(const FileName: string; IgnoreEncoding : Boolean); 1533 1534Var TheStream : TFileStream; 1535 1536begin 1537 TheStream:=TFileStream.Create(FileName,fmCreate); 1538 try 1539 SaveToStream(TheStream, IgnoreEncoding); 1540 finally 1541 TheStream.Free; 1542 end; 1543end; 1544 1545 1546 1547Procedure TStrings.SaveToFile(const FileName: string; AEncoding: TEncoding); 1548 1549Var TheStream : TFileStream; 1550 1551begin 1552 TheStream:=TFileStream.Create(FileName,fmCreate); 1553 try 1554 SaveToStream(TheStream,AEncoding); 1555 finally 1556 TheStream.Free; 1557 end; 1558end; 1559 1560 1561 1562Procedure TStrings.SaveToStream(Stream: TStream); 1563begin 1564 SaveToStream(Stream,False) 1565end; 1566 1567 1568 1569Procedure TStrings.SaveToStream(Stream: TStream; IgnoreEncoding: Boolean); 1570Var 1571 I,L,NLS : SizeInt; 1572 S,NL : String; 1573 1574begin 1575 if not IgnoreEncoding then 1576 begin 1577 SaveToStream(Stream,FEncoding); 1578 Exit; 1579 end; 1580 NL:=GetLineBreakCharLBS; 1581 NLS:=Length(NL)*SizeOf(Char); 1582 For i:=0 To count-1 do 1583 begin 1584 S:=Strings[I]; 1585 L:=Length(S); 1586 if L<>0 then 1587 Stream.WriteBuffer(S[1], L*SizeOf(Char)); 1588 if (I<Count-1) or Not SkipLastLineBreak then 1589 Stream.WriteBuffer(NL[1], NLS); 1590 end; 1591end; 1592 1593 1594 1595 1596Procedure TStrings.SaveToStream(Stream: TStream; AEncoding: TEncoding); 1597 1598Var B,BNL : TBytes; 1599 NL,S: string; 1600 i,BNLS: SizeInt; 1601 1602begin 1603 if AEncoding=nil then 1604 AEncoding:=FDefaultEncoding; 1605 if WriteBOM then 1606 begin 1607 B:=AEncoding.GetPreamble; 1608 if Length(B)>0 then 1609 Stream.WriteBuffer(B[0],Length(B)); 1610 end; 1611 1612 NL := GetLineBreakCharLBS; 1613 BNL:=AEncoding.GetAnsiBytes(NL); 1614 BNLS:=Length(BNL); 1615 For i:=0 To count-1 do 1616 begin 1617 S:=Strings[I]; 1618 if S<>'' then 1619 begin 1620 B:=AEncoding.GetAnsiBytes(S); 1621 Stream.WriteBuffer(B[0],Length(B)); 1622 end; 1623 if (I<Count-1) or Not SkipLastLineBreak then 1624 Stream.WriteBuffer(BNL[0],BNLS); 1625 end; 1626end; 1627 1628 1629 1630 1631Procedure TStrings.SetText(TheText: PChar); 1632 1633Var S : String; 1634 1635begin 1636 If TheText<>Nil then 1637 S:=StrPas(TheText) 1638 else 1639 S:=''; 1640 SetTextStr(S); 1641end; 1642 1643 1644{****************************************************************************} 1645{* TStringList *} 1646{****************************************************************************} 1647 1648{$if not defined(FPC_TESTGENERICS)} 1649 1650procedure TStringList.ExchangeItemsInt(Index1, Index2: Integer); 1651 1652Var P1,P2 : Pointer; 1653 1654begin 1655 P1:=Pointer(Flist^[Index1].FString); 1656 P2:=Pointer(Flist^[Index1].FObject); 1657 Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring); 1658 Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject); 1659 Pointer(Flist^[Index2].Fstring):=P1; 1660 Pointer(Flist^[Index2].FObject):=P2; 1661end; 1662 1663function TStringList.GetSorted: Boolean; 1664begin 1665 Result:=FSortStyle in [sslUser,sslAuto]; 1666end; 1667 1668 1669procedure TStringList.ExchangeItems(Index1, Index2: Integer); 1670begin 1671 ExchangeItemsInt(Index1, Index2); 1672end; 1673 1674 1675procedure TStringList.Grow; 1676 1677Var 1678 NC : Integer; 1679 1680begin 1681 NC:=FCapacity; 1682 If NC>=256 then 1683 NC:=NC+(NC Div 4) 1684 else if NC=0 then 1685 NC:=4 1686 else 1687 NC:=NC*4; 1688 SetCapacity(NC); 1689end; 1690 1691procedure TStringList.InternalClear(FromIndex: Integer; ClearOnly: Boolean); 1692 1693Var 1694 I: Integer; 1695 1696begin 1697 if FromIndex < FCount then 1698 begin 1699 if FOwnsObjects then 1700 begin 1701 For I:=FromIndex to FCount-1 do 1702 begin 1703 Flist^[I].FString:=''; 1704 freeandnil(Flist^[i].FObject); 1705 end; 1706 end 1707 else 1708 begin 1709 For I:=FromIndex to FCount-1 do 1710 Flist^[I].FString:=''; 1711 end; 1712 FCount:=FromIndex; 1713 end; 1714 if Not ClearOnly then 1715 SetCapacity(0); 1716end; 1717 1718procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare 1719 ); 1720var 1721 Pivot, vL, vR: Integer; 1722 ExchangeProc: procedure(Left, Right: Integer) of object; 1723begin 1724 //if ExchangeItems is override call that, else call (faster) ExchangeItemsInt 1725 if TMethod(@Self.ExchangeItems).Code = CodePointer(@TStringList.ExchangeItems) then 1726 ExchangeProc := @ExchangeItemsInt 1727 else 1728 ExchangeProc := @ExchangeItems; 1729 1730 if R - L <= 1 then begin // a little bit of time saver 1731 if L < R then 1732 if CompareFn(Self, L, R) > 0 then 1733 ExchangeProc(L, R); 1734 1735 Exit; 1736 end; 1737 1738 vL := L; 1739 vR := R; 1740 1741 Pivot := L + Random(R - L); // they say random is best 1742 1743 while vL < vR do begin 1744 while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do 1745 Inc(vL); 1746 1747 while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do 1748 Dec(vR); 1749 1750 ExchangeProc(vL, vR); 1751 1752 if Pivot = vL then // swap pivot if we just hit it from one side 1753 Pivot := vR 1754 else if Pivot = vR then 1755 Pivot := vL; 1756 end; 1757 1758 if Pivot - 1 >= L then 1759 QuickSort(L, Pivot - 1, CompareFn); 1760 if Pivot + 1 <= R then 1761 QuickSort(Pivot + 1, R, CompareFn); 1762end; 1763 1764 1765procedure TStringList.InsertItem(Index: Integer; const S: string); 1766begin 1767 InsertItem(Index, S, nil); 1768end; 1769 1770 1771procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject); 1772begin 1773 Changing; 1774 If FCount=Fcapacity then Grow; 1775 If Index<FCount then 1776 System.Move (FList^[Index],FList^[Index+1], 1777 (FCount-Index)*SizeOf(TStringItem)); 1778 Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize... 1779 Flist^[Index].FString:=S; 1780 Flist^[Index].FObject:=O; 1781 Inc(FCount); 1782 Changed; 1783end; 1784 1785 1786procedure TStringList.SetSorted(Value: Boolean); 1787 1788begin 1789 If Value then 1790 SortStyle:=sslAuto 1791 else 1792 SortStyle:=sslNone 1793end; 1794 1795 1796 1797procedure TStringList.Changed; 1798 1799begin 1800 If (FUpdateCount=0) Then 1801 begin 1802 If Assigned(FOnChange) then 1803 FOnchange(Self); 1804 FPONotifyObservers(Self,ooChange,Nil); 1805 end; 1806end; 1807 1808 1809 1810procedure TStringList.Changing; 1811 1812begin 1813 If FUpdateCount=0 then 1814 if Assigned(FOnChanging) then 1815 FOnchanging(Self); 1816end; 1817 1818 1819 1820function TStringList.Get(Index: Integer): string; 1821 1822begin 1823 CheckIndex(Index); 1824 Result:=Flist^[Index].FString; 1825end; 1826 1827 1828 1829function TStringList.GetCapacity: Integer; 1830 1831begin 1832 Result:=FCapacity; 1833end; 1834 1835 1836 1837function TStringList.GetCount: Integer; 1838 1839begin 1840 Result:=FCount; 1841end; 1842 1843 1844 1845function TStringList.GetObject(Index: Integer): TObject; 1846 1847begin 1848 CheckIndex(Index); 1849 Result:=Flist^[Index].FObject; 1850end; 1851 1852 1853 1854procedure TStringList.Put(Index: Integer; const S: string); 1855 1856begin 1857 If Sorted then 1858 Error(SSortedListError,0); 1859 CheckIndex(Index); 1860 Changing; 1861 Flist^[Index].FString:=S; 1862 Changed; 1863end; 1864 1865 1866 1867procedure TStringList.PutObject(Index: Integer; AObject: TObject); 1868 1869begin 1870 CheckIndex(Index); 1871 Changing; 1872 Flist^[Index].FObject:=AObject; 1873 Changed; 1874end; 1875 1876 1877 1878procedure TStringList.SetCapacity(NewCapacity: Integer); 1879 1880Var NewList : Pointer; 1881 MSize : Longint; 1882 1883begin 1884 If (NewCapacity<0) then 1885 Error (SListCapacityError,NewCapacity); 1886 If NewCapacity>FCapacity then 1887 begin 1888 GetMem (NewList,NewCapacity*SizeOf(TStringItem)); 1889 If NewList=Nil then 1890 Error (SListCapacityError,NewCapacity); 1891 If Assigned(FList) then 1892 begin 1893 MSize:=FCapacity*Sizeof(TStringItem); 1894 System.Move (FList^,NewList^,MSize); 1895 FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*(SizeOf(TStringItem) div SizeOf(Word)), 0); 1896 FreeMem (Flist,MSize); 1897 end; 1898 Flist:=NewList; 1899 FCapacity:=NewCapacity; 1900 end 1901 else if NewCapacity<FCapacity then 1902 begin 1903 if NewCapacity = 0 then 1904 begin 1905 if FCount > 0 then 1906 InternalClear(0,True); 1907 FreeMem(FList); 1908 FList := nil; 1909 end else 1910 begin 1911 InternalClear(NewCapacity,True); 1912 GetMem(NewList, NewCapacity * SizeOf(TStringItem)); 1913 System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem)); 1914 FreeMem(FList); 1915 FList := NewList; 1916 end; 1917 FCapacity:=NewCapacity; 1918 end; 1919end; 1920 1921 1922 1923procedure TStringList.SetUpdateState(Updating: Boolean); 1924 1925begin 1926 If Updating then 1927 Changing 1928 else 1929 Changed 1930end; 1931 1932 1933 1934destructor TStringList.Destroy; 1935 1936begin 1937 InternalClear; 1938 Inherited destroy; 1939end; 1940 1941 1942 1943function TStringList.Add(const S: string): Integer; 1944 1945begin 1946 If (SortStyle<>sslAuto) then 1947 Result:=FCount 1948 else 1949 If Find (S,Result) then 1950 Case DUplicates of 1951 DupIgnore : Exit; 1952 DupError : Error(SDuplicateString,0) 1953 end; 1954 InsertItem (Result,S); 1955end; 1956 1957procedure TStringList.Clear; 1958 1959begin 1960 if FCount = 0 then Exit; 1961 Changing; 1962 InternalClear; 1963 Changed; 1964end; 1965 1966procedure TStringList.Delete(Index: Integer); 1967 1968begin 1969 CheckIndex(Index); 1970 Changing; 1971 Flist^[Index].FString:=''; 1972 if FOwnsObjects then 1973 FreeAndNil(Flist^[Index].FObject); 1974 Dec(FCount); 1975 If Index<FCount then 1976 System.Move(Flist^[Index+1], 1977 Flist^[Index], 1978 (Fcount-Index)*SizeOf(TStringItem)); 1979 Changed; 1980end; 1981 1982 1983 1984procedure TStringList.Exchange(Index1, Index2: Integer); 1985 1986begin 1987 CheckIndex(Index1); 1988 CheckIndex(Index2); 1989 Changing; 1990 ExchangeItemsInt(Index1,Index2); 1991 changed; 1992end; 1993 1994 1995procedure TStringList.SetCaseSensitive(b : boolean); 1996begin 1997 if b=FCaseSensitive then 1998 Exit; 1999 FCaseSensitive:=b; 2000 if FSortStyle=sslAuto then 2001 begin 2002 FForceSort:=True; 2003 try 2004 Sort; 2005 finally 2006 FForceSort:=False; 2007 end; 2008 end; 2009end; 2010 2011procedure TStringList.SetSortStyle(AValue: TStringsSortStyle); 2012begin 2013 if FSortStyle=AValue then Exit; 2014 if (AValue=sslAuto) then 2015 Sort; 2016 FSortStyle:=AValue; 2017end; 2018 2019procedure TStringList.CheckIndex(AIndex: Integer); 2020begin 2021 If (AIndex<0) or (AIndex>=FCount) then 2022 Error(SListIndexError,AIndex); 2023end; 2024 2025 2026function TStringList.DoCompareText(const s1, s2: string): PtrInt; 2027begin 2028 if FCaseSensitive then 2029 begin 2030 if UseLocale then 2031 result:=AnsiCompareStr(s1,s2) 2032 else 2033 result:=CompareStr(s1,s2); 2034 end else 2035 begin 2036 if UseLocale then 2037 result:=AnsiCompareText(s1,s2) 2038 else 2039 result:=CompareText(s1,s2); 2040 end; 2041end; 2042 2043 2044function TStringList.Find(const S: string; out Index: Integer): Boolean; 2045 2046var 2047 L, R, I: Integer; 2048 CompareRes: PtrInt; 2049begin 2050 Result := false; 2051 Index:=-1; 2052 if Not Sorted then 2053 Raise EListError.Create(SErrFindNeedsSortedList); 2054 // Use binary search. 2055 L := 0; 2056 R := Count - 1; 2057 while (L<=R) do 2058 begin 2059 I := L + (R - L) div 2; 2060 CompareRes := DoCompareText(S, Flist^[I].FString); 2061 if (CompareRes>0) then 2062 L := I+1 2063 else begin 2064 R := I-1; 2065 if (CompareRes=0) then begin 2066 Result := true; 2067 if (Duplicates<>dupAccept) then 2068 L := I; // forces end of while loop 2069 end; 2070 end; 2071 end; 2072 Index := L; 2073end; 2074 2075 2076 2077function TStringList.IndexOf(const S: string): Integer; 2078 2079begin 2080 If Not Sorted then 2081 Result:=Inherited indexOf(S) 2082 else 2083 // faster using binary search... 2084 If Not Find (S,Result) then 2085 Result:=-1; 2086end; 2087 2088 2089 2090procedure TStringList.Insert(Index: Integer; const S: string); 2091 2092begin 2093 If SortStyle=sslAuto then 2094 Error (SSortedListError,0) 2095 else 2096 begin 2097 If (Index<0) or (Index>FCount) then 2098 Error(SListIndexError,Index); // Cannot use CheckIndex, because there >= FCount... 2099 InsertItem (Index,S); 2100 end; 2101end; 2102 2103 2104procedure TStringList.CustomSort(CompareFn: TStringListSortCompare); 2105 2106begin 2107 If (FCount>1) and (FForceSort or (FSortStyle<>sslAuto)) then 2108 begin 2109 Changing; 2110 QuickSort(0,FCount-1, CompareFn); 2111 Changed; 2112 end; 2113end; 2114 2115function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer; 2116 2117begin 2118 Result := List.DoCompareText(List.FList^[Index1].FString, 2119 List.FList^[Index].FString); 2120end; 2121 2122procedure TStringList.Sort; 2123 2124begin 2125 CustomSort(@StringListAnsiCompare); 2126end; 2127 2128{$else} 2129 2130{ generics based implementation of TStringList follows } 2131 2132function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer; 2133begin 2134 Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]); 2135end; 2136 2137constructor TStringList.Create; 2138begin 2139 inherited; 2140 FOwnsObjects:=false; 2141 FMap := TFPStrObjMap.Create; 2142 FMap.OnPtrCompare := @MapPtrCompare; 2143 FOnCompareText := @DefaultCompareText; 2144 NameValueSeparator:='='; 2145 CheckSpecialChars; 2146end; 2147 2148destructor TStringList.Destroy; 2149begin 2150 FMap.Free; 2151 inherited; 2152end; 2153 2154function TStringList.GetDuplicates: TDuplicates; 2155begin 2156 Result := FMap.Duplicates; 2157end; 2158 2159function TStringList.GetSorted: boolean; 2160begin 2161 Result := FMap.Sorted; 2162end; 2163 2164procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates); 2165begin 2166 FMap.Duplicates := NewDuplicates; 2167end; 2168 2169procedure TStringList.SetSorted(NewSorted: Boolean); 2170begin 2171 FMap.Sorted := NewSorted; 2172end; 2173 2174procedure TStringList.Changed; 2175begin 2176 if FUpdateCount = 0 then 2177 if Assigned(FOnChange) then 2178 FOnChange(Self); 2179end; 2180 2181procedure TStringList.Changing; 2182begin 2183 if FUpdateCount = 0 then 2184 if Assigned(FOnChanging) then 2185 FOnChanging(Self); 2186end; 2187 2188function TStringList.Get(Index: Integer): string; 2189begin 2190 Result := FMap.Keys[Index]; 2191end; 2192 2193function TStringList.GetCapacity: Integer; 2194begin 2195 Result := FMap.Capacity; 2196end; 2197 2198function TStringList.GetCount: Integer; 2199begin 2200 Result := FMap.Count; 2201end; 2202 2203function TStringList.GetObject(Index: Integer): TObject; 2204begin 2205 Result := FMap.Data[Index]; 2206end; 2207 2208procedure TStringList.Put(Index: Integer; const S: string); 2209begin 2210 Changing; 2211 FMap.Keys[Index] := S; 2212 Changed; 2213end; 2214 2215procedure TStringList.PutObject(Index: Integer; AObject: TObject); 2216begin 2217 Changing; 2218 FMap.Data[Index] := AObject; 2219 Changed; 2220end; 2221 2222procedure TStringList.SetCapacity(NewCapacity: Integer); 2223begin 2224 FMap.Capacity := NewCapacity; 2225end; 2226 2227procedure TStringList.SetUpdateState(Updating: Boolean); 2228begin 2229 if Updating then 2230 Changing 2231 else 2232 Changed 2233end; 2234 2235function TStringList.Add(const S: string): Integer; 2236begin 2237 Result := FMap.Add(S); 2238end; 2239 2240procedure TStringList.Clear; 2241begin 2242 if FMap.Count = 0 then exit; 2243 Changing; 2244 FMap.Clear; 2245 Changed; 2246end; 2247 2248procedure TStringList.Delete(Index: Integer); 2249begin 2250 if (Index < 0) or (Index >= FMap.Count) then 2251 Error(SListIndexError, Index); 2252 Changing; 2253 FMap.Delete(Index); 2254 Changed; 2255end; 2256 2257procedure TStringList.Exchange(Index1, Index2: Integer); 2258begin 2259 if (Index1 < 0) or (Index1 >= FMap.Count) then 2260 Error(SListIndexError, Index1); 2261 if (Index2 < 0) or (Index2 >= FMap.Count) then 2262 Error(SListIndexError, Index2); 2263 Changing; 2264 FMap.InternalExchange(Index1, Index2); 2265 Changed; 2266end; 2267 2268procedure TStringList.SetCaseSensitive(NewSensitive: Boolean); 2269begin 2270 if NewSensitive <> FCaseSensitive then 2271 begin 2272 FCaseSensitive := NewSensitive; 2273 if Sorted then 2274 Sort; 2275 end; 2276end; 2277 2278function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer; 2279begin 2280 Result := FOnCompareText(string(Key1^), string(Key2^)); 2281end; 2282 2283function TStringList.DefaultCompareText(const s1, s2: string): PtrInt; 2284begin 2285 if FCaseSensitive then 2286 Result := AnsiCompareStr(s1, s2) 2287 else 2288 Result := AnsiCompareText(s1, s2); 2289end; 2290 2291function TStringList.DoCompareText(const s1, s2: string): PtrInt; 2292begin 2293 Result := FOnCompareText(s1, s2); 2294end; 2295 2296function TStringList.Find(const S: string; var Index: Integer): Boolean; 2297begin 2298 Result := FMap.Find(S, Index); 2299end; 2300 2301function TStringList.IndexOf(const S: string): Integer; 2302begin 2303 Result := FMap.IndexOf(S); 2304end; 2305 2306procedure TStringList.Insert(Index: Integer; const S: string); 2307begin 2308 if not Sorted and (0 <= Index) and (Index < FMap.Count) then 2309 Changing; 2310 FMap.InsertKey(Index, S); 2311 Changed; 2312end; 2313 2314procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare); 2315var 2316 I, J, Pivot: Integer; 2317begin 2318 repeat 2319 I := L; 2320 J := R; 2321 Pivot := (L + R) div 2; 2322 repeat 2323 while CompareFn(Self, I, Pivot) < 0 do Inc(I); 2324 while CompareFn(Self, J, Pivot) > 0 do Dec(J); 2325 if I <= J then 2326 begin 2327 FMap.InternalExchange(I, J); // No check, indices are correct. 2328 if Pivot = I then 2329 Pivot := J 2330 else if Pivot = J then 2331 Pivot := I; 2332 Inc(I); 2333 Dec(j); 2334 end; 2335 until I > J; 2336 if L < J then 2337 QuickSort(L,J, CompareFn); 2338 L := I; 2339 until I >= R; 2340end; 2341 2342procedure TStringList.CustomSort(CompareFn: TStringListSortCompare); 2343begin 2344 if not Sorted and (FMap.Count > 1) then 2345 begin 2346 Changing; 2347 QuickSort(0, FMap.Count-1, CompareFn); 2348 Changed; 2349 end; 2350end; 2351 2352procedure TStringList.Sort; 2353begin 2354 if not Sorted and (FMap.Count > 1) then 2355 begin 2356 Changing; 2357 FMap.Sort; 2358 Changed; 2359 end; 2360end; 2361 2362{$endif} 2363 2364