stringl.inc 40 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 1999-2000 by the Free Pascal development team
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. {****************************************************************************}
  11. {* TStringsEnumerator *}
  12. {****************************************************************************}
  13. constructor TStringsEnumerator.Create(AStrings: TStrings);
  14. begin
  15. inherited Create;
  16. FStrings := AStrings;
  17. FPosition := -1;
  18. end;
  19. function TStringsEnumerator.GetCurrent: String;
  20. begin
  21. Result := FStrings[FPosition];
  22. end;
  23. function TStringsEnumerator.MoveNext: Boolean;
  24. begin
  25. Inc(FPosition);
  26. Result := FPosition < FStrings.Count;
  27. end;
  28. {****************************************************************************}
  29. {* TStrings *}
  30. {****************************************************************************}
  31. // Function to quote text. Should move maybe to sysutils !!
  32. // Also, it is not clear at this point what exactly should be done.
  33. { //!! is used to mark unsupported things. }
  34. Function QuoteString (Const S : String; Const Quote : String) : String;
  35. Var
  36. I,J : Integer;
  37. begin
  38. J:=0;
  39. Result:=S;
  40. for i:=1 to length(s) do
  41. begin
  42. inc(j);
  43. if S[i]=Quote then
  44. begin
  45. System.Insert(Quote,Result,J);
  46. inc(j);
  47. end;
  48. end;
  49. Result:=Quote+Result+Quote;
  50. end;
  51. {
  52. For compatibility we can't add a Constructor to TSTrings to initialize
  53. the special characters. Therefore we add a routine which is called whenever
  54. the special chars are needed.
  55. }
  56. Procedure Tstrings.CheckSpecialChars;
  57. begin
  58. If Not FSpecialCharsInited then
  59. begin
  60. FQuoteChar:='"';
  61. FDelimiter:=',';
  62. FNameValueSeparator:='=';
  63. FLBS:=DefaultTextLineBreakStyle;
  64. FSpecialCharsInited:=true;
  65. FLineBreak:=sLineBreak;
  66. end;
  67. end;
  68. Function TStrings.GetSkipLastLineBreak : Boolean;
  69. begin
  70. CheckSpecialChars;
  71. Result:=FSkipLastLineBreak;
  72. end;
  73. procedure TStrings.SetSkipLastLineBreak(const AValue : Boolean);
  74. begin
  75. CheckSpecialChars;
  76. FSkipLastLineBreak:=AValue;
  77. end;
  78. Function TStrings.GetLBS : TTextLineBreakStyle;
  79. begin
  80. CheckSpecialChars;
  81. Result:=FLBS;
  82. end;
  83. Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle);
  84. begin
  85. CheckSpecialChars;
  86. FLBS:=AValue;
  87. end;
  88. procedure TStrings.SetDelimiter(c:Char);
  89. begin
  90. CheckSpecialChars;
  91. FDelimiter:=c;
  92. end;
  93. Procedure TStrings.SetEncoding(const AEncoding: TEncoding);
  94. begin
  95. if (FEncoding<>nil) and not TEncoding.IsStandardEncoding(FEncoding) then
  96. FEncoding.Free;
  97. if TEncoding.IsStandardEncoding(AEncoding) then
  98. FEncoding:=AEncoding
  99. else if AEncoding<>nil then
  100. FEncoding:=AEncoding.Clone
  101. else
  102. FEncoding:=nil;
  103. end;
  104. Function TStrings.GetDelimiter : Char;
  105. begin
  106. CheckSpecialChars;
  107. Result:=FDelimiter;
  108. end;
  109. procedure TStrings.SetLineBreak(Const S : String);
  110. begin
  111. CheckSpecialChars;
  112. FLineBreak:=S;
  113. end;
  114. Function TStrings.GetLineBreak : String;
  115. begin
  116. CheckSpecialChars;
  117. Result:=FLineBreak;
  118. end;
  119. procedure TStrings.SetQuoteChar(c:Char);
  120. begin
  121. CheckSpecialChars;
  122. FQuoteChar:=c;
  123. end;
  124. Function TStrings.GetQuoteChar :Char;
  125. begin
  126. CheckSpecialChars;
  127. Result:=FQuoteChar;
  128. end;
  129. procedure TStrings.SetNameValueSeparator(c:Char);
  130. begin
  131. CheckSpecialChars;
  132. FNameValueSeparator:=c;
  133. end;
  134. Function TStrings.GetNameValueSeparator :Char;
  135. begin
  136. CheckSpecialChars;
  137. Result:=FNameValueSeparator;
  138. end;
  139. function TStrings.GetCommaText: string;
  140. Var
  141. C1,C2 : Char;
  142. FSD : Boolean;
  143. begin
  144. CheckSpecialChars;
  145. FSD:=StrictDelimiter;
  146. C1:=Delimiter;
  147. C2:=QuoteChar;
  148. Delimiter:=',';
  149. QuoteChar:='"';
  150. StrictDelimiter:=False;
  151. Try
  152. Result:=GetDelimitedText;
  153. Finally
  154. Delimiter:=C1;
  155. QuoteChar:=C2;
  156. StrictDelimiter:=FSD;
  157. end;
  158. end;
  159. Function TStrings.GetDelimitedText: string;
  160. Var
  161. I : integer;
  162. p : pchar;
  163. BreakChars : set of char;
  164. S : String;
  165. doQuote : Boolean;
  166. begin
  167. CheckSpecialChars;
  168. result:='';
  169. if StrictDelimiter then
  170. BreakChars:=[#0,QuoteChar,Delimiter]
  171. else
  172. BreakChars:=[#0..' ',QuoteChar,Delimiter];
  173. // Check for break characters and quote if required.
  174. For i:=0 to count-1 do
  175. begin
  176. S:=Strings[i];
  177. doQuote:=FAlwaysQuote;
  178. If not DoQuote then
  179. begin
  180. p:=pchar(S);
  181. //Quote strings that include BreakChars:
  182. while not(p^ in BreakChars) do
  183. inc(p);
  184. DoQuote:=(p<>pchar(S)+length(S));
  185. end;
  186. if DoQuote then
  187. Result:=Result+QuoteString(S,QuoteChar)
  188. else
  189. Result:=Result+S;
  190. if I<Count-1 then
  191. Result:=Result+Delimiter;
  192. end;
  193. // Quote empty string:
  194. If (Length(Result)=0) and (Count=1) then
  195. Result:=QuoteChar+QuoteChar;
  196. end;
  197. procedure TStrings.GetNameValue(Index : Integer; Out AName,AValue : String);
  198. Var L : longint;
  199. begin
  200. CheckSpecialChars;
  201. AValue:=Strings[Index];
  202. L:=Pos(FNameValueSeparator,AValue);
  203. If L<>0 then
  204. begin
  205. AName:=Copy(AValue,1,L-1);
  206. System.Delete(AValue,1,L);
  207. end
  208. else
  209. AName:='';
  210. end;
  211. function TStrings.ExtractName(const s:String):String;
  212. var
  213. L: Longint;
  214. begin
  215. CheckSpecialChars;
  216. L:=Pos(FNameValueSeparator,S);
  217. If L<>0 then
  218. Result:=Copy(S,1,L-1)
  219. else
  220. Result:='';
  221. end;
  222. function TStrings.GetName(Index: Integer): string;
  223. Var
  224. V : String;
  225. begin
  226. GetNameValue(Index,Result,V);
  227. end;
  228. Function TStrings.GetValue(const Name: string): string;
  229. Var
  230. L : longint;
  231. N : String;
  232. begin
  233. Result:='';
  234. L:=IndexOfName(Name);
  235. If L<>-1 then
  236. GetNameValue(L,N,Result);
  237. end;
  238. Function TStrings.GetValueFromIndex(Index: Integer): string;
  239. Var
  240. N : String;
  241. begin
  242. GetNameValue(Index,N,Result);
  243. end;
  244. Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string);
  245. begin
  246. If (Value='') then
  247. Delete(Index)
  248. else
  249. begin
  250. If (Index<0) then
  251. Index:=Add('');
  252. CheckSpecialChars;
  253. Strings[Index]:=GetName(Index)+FNameValueSeparator+Value;
  254. end;
  255. end;
  256. procedure TStrings.ReadData(Reader: TReader);
  257. begin
  258. Reader.ReadListBegin;
  259. BeginUpdate;
  260. try
  261. Clear;
  262. while not Reader.EndOfList do
  263. Add(Reader.ReadString);
  264. finally
  265. EndUpdate;
  266. end;
  267. Reader.ReadListEnd;
  268. end;
  269. Procedure TStrings.SetDelimitedText(const AValue: string);
  270. var i,j:integer;
  271. aNotFirst:boolean;
  272. begin
  273. CheckSpecialChars;
  274. BeginUpdate;
  275. i:=1;
  276. j:=1;
  277. aNotFirst:=false;
  278. { Paraphrased from Delphi XE2 help:
  279. Strings must be separated by Delimiter characters or spaces.
  280. They may be enclosed in QuoteChars.
  281. QuoteChars in the string must be repeated to distinguish them from the QuoteChars enclosing the string.
  282. }
  283. try
  284. Clear;
  285. If StrictDelimiter then
  286. begin
  287. while i<=length(AValue) do begin
  288. // skip delimiter
  289. if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
  290. // read next string
  291. if i<=length(AValue) then begin
  292. if AValue[i]=FQuoteChar then begin
  293. // next string is quoted
  294. j:=i+1;
  295. while (j<=length(AValue)) and
  296. ( (AValue[j]<>FQuoteChar) or
  297. ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
  298. if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
  299. else inc(j);
  300. end;
  301. // j is position of closing quote
  302. Add( StringReplace (Copy(AValue,i+1,j-i-1),
  303. FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
  304. i:=j+1;
  305. end else begin
  306. // next string is not quoted; read until delimiter
  307. j:=i;
  308. while (j<=length(AValue)) and
  309. (AValue[j]<>FDelimiter) do inc(j);
  310. Add( Copy(AValue,i,j-i));
  311. i:=j;
  312. end;
  313. end else begin
  314. if aNotFirst then Add('');
  315. end;
  316. aNotFirst:=true;
  317. end;
  318. end
  319. else
  320. begin
  321. while i<=length(AValue) do begin
  322. // skip delimiter
  323. if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
  324. // skip spaces
  325. while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
  326. // read next string
  327. if i<=length(AValue) then begin
  328. if AValue[i]=FQuoteChar then begin
  329. // next string is quoted
  330. j:=i+1;
  331. while (j<=length(AValue)) and
  332. ( (AValue[j]<>FQuoteChar) or
  333. ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
  334. if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
  335. else inc(j);
  336. end;
  337. // j is position of closing quote
  338. Add( StringReplace (Copy(AValue,i+1,j-i-1),
  339. FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
  340. i:=j+1;
  341. end else begin
  342. // next string is not quoted; read until control character/space/delimiter
  343. j:=i;
  344. while (j<=length(AValue)) and
  345. (Ord(AValue[j])>Ord(' ')) and
  346. (AValue[j]<>FDelimiter) do inc(j);
  347. Add( Copy(AValue,i,j-i));
  348. i:=j;
  349. end;
  350. end else begin
  351. if aNotFirst then Add('');
  352. end;
  353. // skip spaces
  354. while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
  355. aNotFirst:=true;
  356. end;
  357. end;
  358. finally
  359. EndUpdate;
  360. end;
  361. end;
  362. Procedure TStrings.SetCommaText(const Value: string);
  363. Var
  364. C1,C2 : Char;
  365. begin
  366. CheckSpecialChars;
  367. C1:=Delimiter;
  368. C2:=QuoteChar;
  369. Delimiter:=',';
  370. QuoteChar:='"';
  371. Try
  372. SetDelimitedText(Value);
  373. Finally
  374. Delimiter:=C1;
  375. QuoteChar:=C2;
  376. end;
  377. end;
  378. Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
  379. begin
  380. end;
  381. Procedure TStrings.SetDefaultEncoding(const ADefaultEncoding: TEncoding);
  382. begin
  383. if (FDefaultEncoding<>nil) and not TEncoding.IsStandardEncoding(FDefaultEncoding) then
  384. FDefaultEncoding.Free;
  385. if TEncoding.IsStandardEncoding(ADefaultEncoding) then
  386. FDefaultEncoding:=ADefaultEncoding
  387. else if ADefaultEncoding<>nil then
  388. FDefaultEncoding:=ADefaultEncoding.Clone
  389. else
  390. FDefaultEncoding:=TEncoding.Default;
  391. end;
  392. Procedure TStrings.SetValue(const Name, Value: string);
  393. Var L : longint;
  394. begin
  395. CheckSpecialChars;
  396. L:=IndexOfName(Name);
  397. if L=-1 then
  398. Add (Name+FNameValueSeparator+Value)
  399. else
  400. Strings[L]:=Name+FNameValueSeparator+value;
  401. end;
  402. procedure TStrings.WriteData(Writer: TWriter);
  403. var
  404. i: Integer;
  405. begin
  406. Writer.WriteListBegin;
  407. for i := 0 to Count - 1 do
  408. Writer.WriteString(Strings[i]);
  409. Writer.WriteListEnd;
  410. end;
  411. procedure TStrings.DefineProperties(Filer: TFiler);
  412. var
  413. HasData: Boolean;
  414. begin
  415. if Assigned(Filer.Ancestor) then
  416. // Only serialize if string list is different from ancestor
  417. if Filer.Ancestor.InheritsFrom(TStrings) then
  418. HasData := not Equals(TStrings(Filer.Ancestor))
  419. else
  420. HasData := True
  421. else
  422. HasData := Count > 0;
  423. Filer.DefineProperty('Strings', @ReadData, @WriteData, HasData);
  424. end;
  425. Procedure TStrings.Error(const Msg: string; Data: Integer);
  426. begin
  427. Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame);
  428. end;
  429. Procedure TStrings.Error(const Msg: pstring; Data: Integer);
  430. begin
  431. Raise EStringListError.CreateFmt(Msg^,[Data]) at get_caller_addr(get_frame), get_caller_frame(get_frame);
  432. end;
  433. Function TStrings.GetCapacity: Integer;
  434. begin
  435. Result:=Count;
  436. end;
  437. Function TStrings.GetObject(Index: Integer): TObject;
  438. begin
  439. Result:=Nil;
  440. end;
  441. Function TStrings.GetTextStr: string;
  442. Var P : Pchar;
  443. I,L,NLS : Longint;
  444. S,NL : String;
  445. begin
  446. CheckSpecialChars;
  447. // Determine needed place
  448. if FLineBreak<>sLineBreak then
  449. NL:=FLineBreak
  450. else
  451. Case FLBS of
  452. tlbsLF : NL:=#10;
  453. tlbsCRLF : NL:=#13#10;
  454. tlbsCR : NL:=#13;
  455. end;
  456. L:=0;
  457. NLS:=Length(NL);
  458. For I:=0 to count-1 do
  459. L:=L+Length(Strings[I])+NLS;
  460. if SkipLastLineBreak then
  461. Dec(L,NLS);
  462. Setlength(Result,L);
  463. P:=Pointer(Result);
  464. For i:=0 To count-1 do
  465. begin
  466. S:=Strings[I];
  467. L:=Length(S);
  468. if L<>0 then
  469. System.Move(Pointer(S)^,P^,L);
  470. P:=P+L;
  471. if (I<Count-1) or Not SkipLastLineBreak then
  472. For L:=1 to NLS do
  473. begin
  474. P^:=NL[L];
  475. inc(P);
  476. end;
  477. end;
  478. end;
  479. Procedure TStrings.Put(Index: Integer; const S: string);
  480. Var Obj : TObject;
  481. begin
  482. Obj:=Objects[Index];
  483. Delete(Index);
  484. InsertObject(Index,S,Obj);
  485. end;
  486. Procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  487. begin
  488. // Empty.
  489. end;
  490. Procedure TStrings.SetCapacity(NewCapacity: Integer);
  491. begin
  492. // Empty.
  493. end;
  494. Class Function TStrings.GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
  495. Var
  496. PS : PChar;
  497. IP,L : Integer;
  498. begin
  499. L:=Length(Value);
  500. S:='';
  501. Result:=False;
  502. If ((L-P)<0) then
  503. exit;
  504. if ((L-P)=0) and (not (value[P] in [#10,#13])) Then
  505. Begin
  506. s:=value[P];
  507. inc(P);
  508. Exit(True);
  509. End;
  510. PS:=PChar(Value)+P-1;
  511. IP:=P;
  512. While ((L-P)>=0) and (not (PS^ in [#10,#13])) do
  513. begin
  514. P:=P+1;
  515. Inc(PS);
  516. end;
  517. SetLength (S,P-IP);
  518. System.Move (Value[IP],Pointer(S)^,P-IP);
  519. If (P<=L) and (Value[P]=#13) then
  520. Inc(P);
  521. If (P<=L) and (Value[P]=#10) then
  522. Inc(P); // Point to character after #10(#13)
  523. Result:=True;
  524. end;
  525. Function TStrings.GetNextLineBreak (Const Value : String; Var S : String; Var P : Integer) : Boolean;
  526. Var
  527. PS,PC,PP : PChar;
  528. begin
  529. S:='';
  530. Result:=False;
  531. If ((Length(Value)-P)<0) then
  532. exit;
  533. PS:=@Value[P];
  534. PC:=PS;
  535. PP:=AnsiStrPos(PS,PChar(FLineBreak));
  536. // Stop on #0.
  537. While (PC^<>#0) and (PC<>PP) do
  538. Inc(PC);
  539. P:=P+(PC-PS)+Length(FLineBreak);
  540. SetString(S,PS,PC-PS);
  541. Result:=True;
  542. end;
  543. Procedure TStrings.DoSetTextStr(const Value: string; DoClear : Boolean);
  544. Var
  545. S : String;
  546. P : Integer;
  547. begin
  548. Try
  549. beginUpdate;
  550. if DoClear then
  551. Clear;
  552. P:=1;
  553. if FLineBreak=sLineBreak then
  554. begin
  555. While GetNextLine (Value,S,P) do
  556. Add(S)
  557. end
  558. else
  559. While GetNextLineBreak (Value,S,P) do
  560. Add(S);
  561. finally
  562. EndUpdate;
  563. end;
  564. end;
  565. Procedure TStrings.SetTextStr(const Value: string);
  566. begin
  567. CheckSpecialChars;
  568. DoSetTextStr(Value,True);
  569. end;
  570. Procedure TStrings.AddText(const S: string);
  571. begin
  572. CheckSpecialChars;
  573. DoSetTextStr(S,False);
  574. end;
  575. Procedure TStrings.SetUpdateState(Updating: Boolean);
  576. begin
  577. FPONotifyObservers(Self,ooChange,Nil);
  578. end;
  579. destructor TSTrings.Destroy;
  580. begin
  581. if (FEncoding<>nil) and not TEncoding.IsStandardEncoding(FEncoding) then
  582. FreeAndNil(FEncoding);
  583. if (FDefaultEncoding<>nil) and not TEncoding.IsStandardEncoding(FDefaultEncoding) then
  584. FreeAndNil(FDefaultEncoding);
  585. inherited destroy;
  586. end;
  587. constructor TStrings.Create;
  588. begin
  589. inherited Create;
  590. FDefaultEncoding:=TEncoding.Default;
  591. FEncoding:=nil;
  592. FWriteBOM:=True;
  593. FAlwaysQuote:=False;
  594. end;
  595. Function TStrings.Add(const S: string): Integer;
  596. begin
  597. Result:=Count;
  598. Insert (Count,S);
  599. end;
  600. function TStrings.Add(const Fmt : string; const Args : Array of const): Integer;
  601. begin
  602. Result:=Add(Format(Fmt,Args));
  603. end;
  604. Function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  605. begin
  606. Result:=Add(S);
  607. Objects[result]:=AObject;
  608. end;
  609. function TStrings.AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer;
  610. begin
  611. Result:=AddObject(Format(Fmt,Args),AObject);
  612. end;
  613. function TStrings.AddPair(const AName, AValue: string): TStrings;
  614. begin
  615. Result:=AddPair(AName,AValue,Nil);
  616. end;
  617. function TStrings.AddPair(const AName, AValue: string; AObject: TObject): TStrings;
  618. begin
  619. Result := Self;
  620. AddObject(Concat(AName, NameValueSeparator, AValue), AObject);
  621. end;
  622. Procedure TStrings.Append(const S: string);
  623. begin
  624. Add (S);
  625. end;
  626. Procedure TStrings.AddStrings(TheStrings: TStrings; ClearFirst : Boolean);
  627. begin
  628. beginupdate;
  629. try
  630. if ClearFirst then
  631. Clear;
  632. AddStrings(TheStrings);
  633. finally
  634. EndUpdate;
  635. end;
  636. end;
  637. Procedure TStrings.AddStrings(TheStrings: TStrings);
  638. Var Runner : longint;
  639. begin
  640. For Runner:=0 to TheStrings.Count-1 do
  641. self.AddObject (Thestrings[Runner],TheStrings.Objects[Runner]);
  642. end;
  643. Procedure TStrings.AddStrings(const TheStrings: array of string);
  644. Var Runner : longint;
  645. begin
  646. if Count + High(TheStrings)+1 > Capacity then
  647. Capacity := Count + High(TheStrings)+1;
  648. For Runner:=Low(TheStrings) to High(TheStrings) do
  649. self.Add(Thestrings[Runner]);
  650. end;
  651. Procedure TStrings.AddStrings(const TheStrings: array of string; ClearFirst : Boolean);
  652. begin
  653. beginupdate;
  654. try
  655. if ClearFirst then
  656. Clear;
  657. AddStrings(TheStrings);
  658. finally
  659. EndUpdate;
  660. end;
  661. end;
  662. Procedure TStrings.Assign(Source: TPersistent);
  663. Var
  664. S : TStrings;
  665. begin
  666. If Source is TStrings then
  667. begin
  668. S:=TStrings(Source);
  669. BeginUpdate;
  670. Try
  671. clear;
  672. FSpecialCharsInited:=S.FSpecialCharsInited;
  673. FQuoteChar:=S.FQuoteChar;
  674. FDelimiter:=S.FDelimiter;
  675. FNameValueSeparator:=S.FNameValueSeparator;
  676. FLBS:=S.FLBS;
  677. FLineBreak:=S.FLineBreak;
  678. FWriteBOM:=S.FWriteBOM;
  679. DefaultEncoding:=S.DefaultEncoding;
  680. SetEncoding(S.Encoding);
  681. AddStrings(S);
  682. finally
  683. EndUpdate;
  684. end;
  685. end
  686. else
  687. Inherited Assign(Source);
  688. end;
  689. Procedure TStrings.BeginUpdate;
  690. begin
  691. if FUpdateCount = 0 then SetUpdateState(true);
  692. inc(FUpdateCount);
  693. end;
  694. Procedure TStrings.EndUpdate;
  695. begin
  696. If FUpdateCount>0 then
  697. Dec(FUpdateCount);
  698. if FUpdateCount=0 then
  699. SetUpdateState(False);
  700. end;
  701. Function TStrings.Equals(Obj: TObject): Boolean;
  702. begin
  703. if Obj is TStrings then
  704. Result := Equals(TStrings(Obj))
  705. else
  706. Result := inherited Equals(Obj);
  707. end;
  708. Function TStrings.Equals(TheStrings: TStrings): Boolean;
  709. Var Runner,Nr : Longint;
  710. begin
  711. Result:=False;
  712. Nr:=Self.Count;
  713. if Nr<>TheStrings.Count then exit;
  714. For Runner:=0 to Nr-1 do
  715. If Strings[Runner]<>TheStrings[Runner] then exit;
  716. Result:=True;
  717. end;
  718. Procedure TStrings.Exchange(Index1, Index2: Integer);
  719. Var
  720. Obj : TObject;
  721. Str : String;
  722. begin
  723. beginUpdate;
  724. Try
  725. Obj:=Objects[Index1];
  726. Str:=Strings[Index1];
  727. Objects[Index1]:=Objects[Index2];
  728. Strings[Index1]:=Strings[Index2];
  729. Objects[Index2]:=Obj;
  730. Strings[Index2]:=Str;
  731. finally
  732. EndUpdate;
  733. end;
  734. end;
  735. function TStrings.GetEnumerator: TStringsEnumerator;
  736. begin
  737. Result:=TStringsEnumerator.Create(Self);
  738. end;
  739. Function TStrings.GetText: PChar;
  740. begin
  741. Result:=StrNew(Pchar(Self.Text));
  742. end;
  743. Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt;
  744. begin
  745. result:=CompareText(s1,s2);
  746. end;
  747. Function TStrings.IndexOf(const S: string): Integer;
  748. begin
  749. Result:=0;
  750. While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1;
  751. if Result=Count then Result:=-1;
  752. end;
  753. Function TStrings.IndexOfName(const Name: string): Integer;
  754. Var
  755. len : longint;
  756. S : String;
  757. begin
  758. CheckSpecialChars;
  759. Result:=0;
  760. while (Result<Count) do
  761. begin
  762. S:=Strings[Result];
  763. len:=pos(FNameValueSeparator,S)-1;
  764. if (len>=0) and (DoCompareText(Name,Copy(S,1,Len))=0) then
  765. exit;
  766. inc(result);
  767. end;
  768. result:=-1;
  769. end;
  770. Function TStrings.IndexOfObject(AObject: TObject): Integer;
  771. begin
  772. Result:=0;
  773. While (Result<count) and (Objects[Result]<>AObject) do Result:=Result+1;
  774. If Result=Count then Result:=-1;
  775. end;
  776. Procedure TStrings.InsertObject(Index: Integer; const S: string;
  777. AObject: TObject);
  778. begin
  779. Insert (Index,S);
  780. Objects[Index]:=AObject;
  781. end;
  782. Procedure TStrings.LoadFromFile(const FileName: string);
  783. begin
  784. LoadFromFile(FileName,False)
  785. end;
  786. Procedure TStrings.LoadFromFile(const FileName: string; IgnoreEncoding : Boolean);
  787. Var
  788. TheStream : TFileStream;
  789. begin
  790. TheStream:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite);
  791. try
  792. LoadFromStream(TheStream, IgnoreEncoding);
  793. finally
  794. TheStream.Free;
  795. end;
  796. end;
  797. Procedure TStrings.LoadFromFile(const FileName: string; AEncoding: TEncoding);
  798. Var
  799. TheStream : TFileStream;
  800. begin
  801. TheStream:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite);
  802. try
  803. LoadFromStream(TheStream,AEncoding);
  804. finally
  805. TheStream.Free;
  806. end;
  807. end;
  808. Procedure TStrings.LoadFromStream(Stream: TStream);
  809. begin
  810. LoadFromStream(Stream,False);
  811. end;
  812. Procedure TStrings.LoadFromStream(Stream: TStream; IgnoreEncoding : Boolean);
  813. {
  814. Borlands method is no good, since a pipe for
  815. instance doesn't have a size.
  816. So we must do it the hard way.
  817. }
  818. Const
  819. BufSize = 1024;
  820. MaxGrow = 1 shl 29;
  821. Var
  822. Buffer : AnsiString;
  823. BytesRead,
  824. BufLen,
  825. I,BufDelta : Longint;
  826. begin
  827. if not IgnoreEncoding then
  828. begin
  829. LoadFromStream(Stream,Nil);
  830. Exit;
  831. end;
  832. // reread into a buffer
  833. beginupdate;
  834. try
  835. Buffer:='';
  836. BufLen:=0;
  837. I:=1;
  838. Repeat
  839. BufDelta:=BufSize*I;
  840. SetLength(Buffer,BufLen+BufDelta);
  841. BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta);
  842. inc(BufLen,BufDelta);
  843. If I<MaxGrow then
  844. I:=I shl 1;
  845. Until BytesRead<>BufDelta;
  846. SetLength(Buffer, BufLen-BufDelta+BytesRead);
  847. SetTextStr(Buffer);
  848. SetLength(Buffer,0);
  849. finally
  850. EndUpdate;
  851. end;
  852. end;
  853. Procedure TStrings.LoadFromStream(Stream: TStream; AEncoding: TEncoding);
  854. {
  855. Borlands method is no good, since a pipe for
  856. instance doesn't have a size.
  857. So we must do it the hard way.
  858. }
  859. Const
  860. BufSize = 1024;
  861. MaxGrow = 1 shl 29;
  862. Var
  863. Buffer : TBytes;
  864. T : string;
  865. BytesRead,
  866. BufLen,
  867. I,BufDelta,
  868. PreambleLength : Longint;
  869. begin
  870. // reread into a buffer
  871. beginupdate;
  872. try
  873. SetLength(Buffer,0);
  874. BufLen:=0;
  875. I:=1;
  876. Repeat
  877. BufDelta:=BufSize*I;
  878. SetLength(Buffer,BufLen+BufDelta);
  879. BytesRead:=Stream.Read(Buffer[BufLen],BufDelta);
  880. inc(BufLen,BufDelta);
  881. If I<MaxGrow then
  882. I:=I shl 1;
  883. Until BytesRead<>BufDelta;
  884. SetLength(Buffer,BufLen-BufDelta+BytesRead);
  885. PreambleLength:=TEncoding.GetBufferEncoding(Buffer,AEncoding,FDefaultEncoding);
  886. T:=AEncoding.GetAnsiString(Buffer,PreambleLength,Length(Buffer)-PreambleLength);
  887. SetEncoding(AEncoding);
  888. SetLength(Buffer,0);
  889. SetTextStr(T);
  890. finally
  891. EndUpdate;
  892. end;
  893. end;
  894. Procedure TStrings.Move(CurIndex, NewIndex: Integer);
  895. Var
  896. Obj : TObject;
  897. Str : String;
  898. begin
  899. BeginUpdate;
  900. Try
  901. Obj:=Objects[CurIndex];
  902. Str:=Strings[CurIndex];
  903. Objects[CurIndex]:=Nil; // Prevent Delete from freeing.
  904. Delete(Curindex);
  905. InsertObject(NewIndex,Str,Obj);
  906. finally
  907. EndUpdate;
  908. end;
  909. end;
  910. Procedure TStrings.SaveToFile(const FileName: string);
  911. Var TheStream : TFileStream;
  912. begin
  913. TheStream:=TFileStream.Create(FileName,fmCreate);
  914. try
  915. SaveToStream(TheStream);
  916. finally
  917. TheStream.Free;
  918. end;
  919. end;
  920. Procedure TStrings.SaveToFile(const FileName: string; AEncoding: TEncoding);
  921. Var TheStream : TFileStream;
  922. begin
  923. TheStream:=TFileStream.Create(FileName,fmCreate);
  924. try
  925. SaveToStream(TheStream,AEncoding);
  926. finally
  927. TheStream.Free;
  928. end;
  929. end;
  930. Procedure TStrings.SaveToStream(Stream: TStream);
  931. Var
  932. S : String;
  933. begin
  934. if Encoding<>nil then
  935. SaveToStream(Stream,Encoding)
  936. else
  937. begin
  938. S:=Text;
  939. if S = '' then Exit;
  940. Stream.WriteBuffer(Pointer(S)^,Length(S));
  941. end;
  942. end;
  943. Procedure TStrings.SaveToStream(Stream: TStream; AEncoding: TEncoding);
  944. Var B : TBytes;
  945. begin
  946. if AEncoding=nil then
  947. AEncoding:=FDefaultEncoding;
  948. if FWriteBOM then
  949. begin
  950. B:=AEncoding.GetPreamble;
  951. if Length(B)>0 then
  952. Stream.WriteBuffer(B[0],Length(B));
  953. end;
  954. B:=AEncoding.GetAnsiBytes(Text);
  955. if Length(B)>0 then
  956. Stream.WriteBuffer(B[0],Length(B));
  957. end;
  958. Procedure TStrings.SetText(TheText: PChar);
  959. Var S : String;
  960. begin
  961. If TheText<>Nil then
  962. S:=StrPas(TheText)
  963. else
  964. S:='';
  965. SetTextStr(S);
  966. end;
  967. {****************************************************************************}
  968. {* TStringList *}
  969. {****************************************************************************}
  970. {$if not defined(FPC_TESTGENERICS)}
  971. procedure TStringList.ExchangeItemsInt(Index1, Index2: Integer);
  972. Var P1,P2 : Pointer;
  973. begin
  974. P1:=Pointer(Flist^[Index1].FString);
  975. P2:=Pointer(Flist^[Index1].FObject);
  976. Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring);
  977. Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject);
  978. Pointer(Flist^[Index2].Fstring):=P1;
  979. Pointer(Flist^[Index2].FObject):=P2;
  980. end;
  981. function TStringList.GetSorted: Boolean;
  982. begin
  983. Result:=FSortStyle in [sslUser,sslAuto];
  984. end;
  985. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  986. begin
  987. ExchangeItemsInt(Index1, Index2);
  988. end;
  989. procedure TStringList.Grow;
  990. Var
  991. NC : Integer;
  992. begin
  993. NC:=FCapacity;
  994. If NC>=256 then
  995. NC:=NC+(NC Div 4)
  996. else if NC=0 then
  997. NC:=4
  998. else
  999. NC:=NC*4;
  1000. SetCapacity(NC);
  1001. end;
  1002. procedure TStringList.InternalClear(FromIndex: Integer; ClearOnly: Boolean);
  1003. Var
  1004. I: Integer;
  1005. begin
  1006. if FromIndex < FCount then
  1007. begin
  1008. if FOwnsObjects then
  1009. begin
  1010. For I:=FromIndex to FCount-1 do
  1011. begin
  1012. Flist^[I].FString:='';
  1013. freeandnil(Flist^[i].FObject);
  1014. end;
  1015. end
  1016. else
  1017. begin
  1018. For I:=FromIndex to FCount-1 do
  1019. Flist^[I].FString:='';
  1020. end;
  1021. FCount:=FromIndex;
  1022. end;
  1023. if Not ClearOnly then
  1024. SetCapacity(0);
  1025. end;
  1026. procedure TStringList.InsertItem(Index: Integer; const S: string);
  1027. begin
  1028. InsertItem(Index, S, nil);
  1029. end;
  1030. procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject);
  1031. begin
  1032. Changing;
  1033. If FCount=Fcapacity then Grow;
  1034. If Index<FCount then
  1035. System.Move (FList^[Index],FList^[Index+1],
  1036. (FCount-Index)*SizeOf(TStringItem));
  1037. Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
  1038. Flist^[Index].FString:=S;
  1039. Flist^[Index].FObject:=O;
  1040. Inc(FCount);
  1041. Changed;
  1042. end;
  1043. procedure TStringList.SetSorted(Value: Boolean);
  1044. begin
  1045. If Value then
  1046. SortStyle:=sslAuto
  1047. else
  1048. SortStyle:=sslNone
  1049. end;
  1050. procedure TStringList.Changed;
  1051. begin
  1052. If (FUpdateCount=0) Then
  1053. begin
  1054. If Assigned(FOnChange) then
  1055. FOnchange(Self);
  1056. FPONotifyObservers(Self,ooChange,Nil);
  1057. end;
  1058. end;
  1059. procedure TStringList.Changing;
  1060. begin
  1061. If FUpdateCount=0 then
  1062. if Assigned(FOnChanging) then
  1063. FOnchanging(Self);
  1064. end;
  1065. function TStringList.Get(Index: Integer): string;
  1066. begin
  1067. CheckIndex(Index);
  1068. Result:=Flist^[Index].FString;
  1069. end;
  1070. function TStringList.GetCapacity: Integer;
  1071. begin
  1072. Result:=FCapacity;
  1073. end;
  1074. function TStringList.GetCount: Integer;
  1075. begin
  1076. Result:=FCount;
  1077. end;
  1078. function TStringList.GetObject(Index: Integer): TObject;
  1079. begin
  1080. CheckIndex(Index);
  1081. Result:=Flist^[Index].FObject;
  1082. end;
  1083. procedure TStringList.Put(Index: Integer; const S: string);
  1084. begin
  1085. If Sorted then
  1086. Error(SSortedListError,0);
  1087. CheckIndex(Index);
  1088. Changing;
  1089. Flist^[Index].FString:=S;
  1090. Changed;
  1091. end;
  1092. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  1093. begin
  1094. CheckIndex(Index);
  1095. Changing;
  1096. Flist^[Index].FObject:=AObject;
  1097. Changed;
  1098. end;
  1099. procedure TStringList.SetCapacity(NewCapacity: Integer);
  1100. Var NewList : Pointer;
  1101. MSize : Longint;
  1102. begin
  1103. If (NewCapacity<0) then
  1104. Error (SListCapacityError,NewCapacity);
  1105. If NewCapacity>FCapacity then
  1106. begin
  1107. GetMem (NewList,NewCapacity*SizeOf(TStringItem));
  1108. If NewList=Nil then
  1109. Error (SListCapacityError,NewCapacity);
  1110. If Assigned(FList) then
  1111. begin
  1112. MSize:=FCapacity*Sizeof(TStringItem);
  1113. System.Move (FList^,NewList^,MSize);
  1114. FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*(SizeOf(TStringItem) div SizeOf(Word)), 0);
  1115. FreeMem (Flist,MSize);
  1116. end;
  1117. Flist:=NewList;
  1118. FCapacity:=NewCapacity;
  1119. end
  1120. else if NewCapacity<FCapacity then
  1121. begin
  1122. if NewCapacity = 0 then
  1123. begin
  1124. if FCount > 0 then
  1125. InternalClear(0,True);
  1126. FreeMem(FList);
  1127. FList := nil;
  1128. end else
  1129. begin
  1130. InternalClear(NewCapacity,True);
  1131. GetMem(NewList, NewCapacity * SizeOf(TStringItem));
  1132. System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
  1133. FreeMem(FList);
  1134. FList := NewList;
  1135. end;
  1136. FCapacity:=NewCapacity;
  1137. end;
  1138. end;
  1139. procedure TStringList.SetUpdateState(Updating: Boolean);
  1140. begin
  1141. If Updating then
  1142. Changing
  1143. else
  1144. Changed
  1145. end;
  1146. destructor TStringList.Destroy;
  1147. begin
  1148. InternalClear;
  1149. Inherited destroy;
  1150. end;
  1151. function TStringList.Add(const S: string): Integer;
  1152. begin
  1153. If Not (SortStyle=sslAuto) then
  1154. Result:=FCount
  1155. else
  1156. If Find (S,Result) then
  1157. Case DUplicates of
  1158. DupIgnore : Exit;
  1159. DupError : Error(SDuplicateString,0)
  1160. end;
  1161. InsertItem (Result,S);
  1162. end;
  1163. procedure TStringList.Clear;
  1164. begin
  1165. if FCount = 0 then Exit;
  1166. Changing;
  1167. InternalClear;
  1168. Changed;
  1169. end;
  1170. procedure TStringList.Delete(Index: Integer);
  1171. begin
  1172. CheckIndex(Index);
  1173. Changing;
  1174. Flist^[Index].FString:='';
  1175. if FOwnsObjects then
  1176. FreeAndNil(Flist^[Index].FObject);
  1177. Dec(FCount);
  1178. If Index<FCount then
  1179. System.Move(Flist^[Index+1],
  1180. Flist^[Index],
  1181. (Fcount-Index)*SizeOf(TStringItem));
  1182. Changed;
  1183. end;
  1184. procedure TStringList.Exchange(Index1, Index2: Integer);
  1185. begin
  1186. CheckIndex(Index1);
  1187. CheckIndex(Index2);
  1188. Changing;
  1189. ExchangeItemsInt(Index1,Index2);
  1190. changed;
  1191. end;
  1192. procedure TStringList.SetCaseSensitive(b : boolean);
  1193. begin
  1194. if b=FCaseSensitive then
  1195. Exit;
  1196. FCaseSensitive:=b;
  1197. if FSortStyle=sslAuto then
  1198. begin
  1199. FForceSort:=True;
  1200. try
  1201. Sort;
  1202. finally
  1203. FForceSort:=False;
  1204. end;
  1205. end;
  1206. end;
  1207. procedure TStringList.SetSortStyle(AValue: TStringsSortStyle);
  1208. begin
  1209. if FSortStyle=AValue then Exit;
  1210. if (AValue=sslAuto) then
  1211. Sort;
  1212. FSortStyle:=AValue;
  1213. end;
  1214. procedure TStringList.CheckIndex(AIndex: Integer);
  1215. begin
  1216. If (AIndex<0) or (AIndex>=FCount) then
  1217. Error(SListIndexError,AIndex);
  1218. end;
  1219. function TStringList.DoCompareText(const s1, s2: string): PtrInt;
  1220. begin
  1221. if FCaseSensitive then
  1222. result:=AnsiCompareStr(s1,s2)
  1223. else
  1224. result:=AnsiCompareText(s1,s2);
  1225. end;
  1226. function TStringList.CompareStrings(const s1,s2 : string) : Integer;
  1227. begin
  1228. Result := DoCompareText(s1, s2);
  1229. end;
  1230. function TStringList.Find(const S: string; out Index: Integer): Boolean;
  1231. var
  1232. L, R, I: Integer;
  1233. CompareRes: PtrInt;
  1234. begin
  1235. Result := false;
  1236. Index:=-1;
  1237. if Not Sorted then
  1238. Raise EListError.Create(SErrFindNeedsSortedList);
  1239. // Use binary search.
  1240. L := 0;
  1241. R := Count - 1;
  1242. while (L<=R) do
  1243. begin
  1244. I := L + (R - L) div 2;
  1245. CompareRes := DoCompareText(S, Flist^[I].FString);
  1246. if (CompareRes>0) then
  1247. L := I+1
  1248. else begin
  1249. R := I-1;
  1250. if (CompareRes=0) then begin
  1251. Result := true;
  1252. if (Duplicates<>dupAccept) then
  1253. L := I; // forces end of while loop
  1254. end;
  1255. end;
  1256. end;
  1257. Index := L;
  1258. end;
  1259. function TStringList.IndexOf(const S: string): Integer;
  1260. begin
  1261. If Not Sorted then
  1262. Result:=Inherited indexOf(S)
  1263. else
  1264. // faster using binary search...
  1265. If Not Find (S,Result) then
  1266. Result:=-1;
  1267. end;
  1268. procedure TStringList.Insert(Index: Integer; const S: string);
  1269. begin
  1270. If SortStyle=sslAuto then
  1271. Error (SSortedListError,0)
  1272. else
  1273. begin
  1274. If (Index<0) or (Index>FCount) then
  1275. Error(SListIndexError,Index); // Cannot use CheckIndex, because there >= FCount...
  1276. InsertItem (Index,S);
  1277. end;
  1278. end;
  1279. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  1280. begin
  1281. CustomSort(CompareFn, SortBase.DefaultSortingAlgorithm);
  1282. end;
  1283. type
  1284. PStringList_CustomSort_Context = ^TStringList_CustomSort_Context;
  1285. TStringList_CustomSort_Context = record
  1286. List: TStringList;
  1287. ListStartPtr: Pointer;
  1288. CompareFn: TStringListSortCompare;
  1289. end;
  1290. function TStringList_CustomSort_Comparer(Item1, Item2, Context: Pointer): Integer;
  1291. begin
  1292. with PStringList_CustomSort_Context(Context)^ do
  1293. Result := CompareFn(List,
  1294. (Item1 - ListStartPtr) div SizeOf(TStringItem),
  1295. (Item2 - ListStartPtr) div SizeOf(TStringItem));
  1296. end;
  1297. procedure TStringList_CustomSort_Exchanger(Item1, Item2, Context: Pointer);
  1298. begin
  1299. with PStringList_CustomSort_Context(Context)^ do
  1300. List.ExchangeItems((Item1 - ListStartPtr) div SizeOf(TStringItem),
  1301. (Item2 - ListStartPtr) div SizeOf(TStringItem));
  1302. end;
  1303. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
  1304. var
  1305. Context: TStringList_CustomSort_Context;
  1306. begin
  1307. If (FForceSort or (Not (FSortStyle=sslAuto))) and (FCount>1) then
  1308. begin
  1309. Changing;
  1310. Context.List := Self;
  1311. Context.ListStartPtr := FList;
  1312. Context.CompareFn := CompareFn;
  1313. //if ExchangeItems is overriden call that, else call (faster) ItemListSorter_ContextComparer
  1314. if TMethod(@Self.ExchangeItems).Code = CodePointer(@TStringList.ExchangeItems) then
  1315. SortingAlgorithm^.ItemListSorter_ContextComparer(
  1316. FList, FCount, SizeOf(TStringItem), @TStringList_CustomSort_Comparer,
  1317. @Context)
  1318. else
  1319. SortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1320. FList, FCount, SizeOf(TStringItem), @TStringList_CustomSort_Comparer,
  1321. @TStringList_CustomSort_Exchanger, @Context);
  1322. Changed;
  1323. end;
  1324. end;
  1325. function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
  1326. begin
  1327. Result := List.DoCompareText(List.FList^[Index1].FString,
  1328. List.FList^[Index].FString);
  1329. end;
  1330. procedure TStringList.Sort;
  1331. begin
  1332. CustomSort(@StringListAnsiCompare);
  1333. end;
  1334. procedure TStringList.Sort(SortingAlgorithm: PSortingAlgorithm);
  1335. begin
  1336. CustomSort(@StringListAnsiCompare, SortingAlgorithm);
  1337. end;
  1338. {$else}
  1339. { generics based implementation of TStringList follows }
  1340. function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
  1341. begin
  1342. Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]);
  1343. end;
  1344. constructor TStringList.Create;
  1345. begin
  1346. inherited;
  1347. FOwnsObjects:=false;
  1348. FMap := TFPStrObjMap.Create;
  1349. FMap.OnPtrCompare := @MapPtrCompare;
  1350. FOnCompareText := @DefaultCompareText;
  1351. NameValueSeparator:='=';
  1352. CheckSpecialChars;
  1353. end;
  1354. destructor TStringList.Destroy;
  1355. begin
  1356. FMap.Free;
  1357. inherited;
  1358. end;
  1359. function TStringList.GetDuplicates: TDuplicates;
  1360. begin
  1361. Result := FMap.Duplicates;
  1362. end;
  1363. function TStringList.GetSorted: boolean;
  1364. begin
  1365. Result := FMap.Sorted;
  1366. end;
  1367. procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates);
  1368. begin
  1369. FMap.Duplicates := NewDuplicates;
  1370. end;
  1371. procedure TStringList.SetSorted(NewSorted: Boolean);
  1372. begin
  1373. FMap.Sorted := NewSorted;
  1374. end;
  1375. procedure TStringList.Changed;
  1376. begin
  1377. if FUpdateCount = 0 then
  1378. if Assigned(FOnChange) then
  1379. FOnChange(Self);
  1380. end;
  1381. procedure TStringList.Changing;
  1382. begin
  1383. if FUpdateCount = 0 then
  1384. if Assigned(FOnChanging) then
  1385. FOnChanging(Self);
  1386. end;
  1387. function TStringList.Get(Index: Integer): string;
  1388. begin
  1389. Result := FMap.Keys[Index];
  1390. end;
  1391. function TStringList.GetCapacity: Integer;
  1392. begin
  1393. Result := FMap.Capacity;
  1394. end;
  1395. function TStringList.GetCount: Integer;
  1396. begin
  1397. Result := FMap.Count;
  1398. end;
  1399. function TStringList.GetObject(Index: Integer): TObject;
  1400. begin
  1401. Result := FMap.Data[Index];
  1402. end;
  1403. procedure TStringList.Put(Index: Integer; const S: string);
  1404. begin
  1405. Changing;
  1406. FMap.Keys[Index] := S;
  1407. Changed;
  1408. end;
  1409. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  1410. begin
  1411. Changing;
  1412. FMap.Data[Index] := AObject;
  1413. Changed;
  1414. end;
  1415. procedure TStringList.SetCapacity(NewCapacity: Integer);
  1416. begin
  1417. FMap.Capacity := NewCapacity;
  1418. end;
  1419. procedure TStringList.SetUpdateState(Updating: Boolean);
  1420. begin
  1421. if Updating then
  1422. Changing
  1423. else
  1424. Changed
  1425. end;
  1426. function TStringList.Add(const S: string): Integer;
  1427. begin
  1428. Result := FMap.Add(S);
  1429. end;
  1430. procedure TStringList.Clear;
  1431. begin
  1432. if FMap.Count = 0 then exit;
  1433. Changing;
  1434. FMap.Clear;
  1435. Changed;
  1436. end;
  1437. procedure TStringList.Delete(Index: Integer);
  1438. begin
  1439. if (Index < 0) or (Index >= FMap.Count) then
  1440. Error(SListIndexError, Index);
  1441. Changing;
  1442. FMap.Delete(Index);
  1443. Changed;
  1444. end;
  1445. procedure TStringList.Exchange(Index1, Index2: Integer);
  1446. begin
  1447. if (Index1 < 0) or (Index1 >= FMap.Count) then
  1448. Error(SListIndexError, Index1);
  1449. if (Index2 < 0) or (Index2 >= FMap.Count) then
  1450. Error(SListIndexError, Index2);
  1451. Changing;
  1452. FMap.InternalExchange(Index1, Index2);
  1453. Changed;
  1454. end;
  1455. procedure TStringList.SetCaseSensitive(NewSensitive: Boolean);
  1456. begin
  1457. if NewSensitive <> FCaseSensitive then
  1458. begin
  1459. FCaseSensitive := NewSensitive;
  1460. if Sorted then
  1461. Sort;
  1462. end;
  1463. end;
  1464. function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer;
  1465. begin
  1466. Result := FOnCompareText(string(Key1^), string(Key2^));
  1467. end;
  1468. function TStringList.DefaultCompareText(const s1, s2: string): PtrInt;
  1469. begin
  1470. if FCaseSensitive then
  1471. Result := AnsiCompareStr(s1, s2)
  1472. else
  1473. Result := AnsiCompareText(s1, s2);
  1474. end;
  1475. function TStringList.DoCompareText(const s1, s2: string): PtrInt;
  1476. begin
  1477. Result := FOnCompareText(s1, s2);
  1478. end;
  1479. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  1480. begin
  1481. Result := FMap.Find(S, Index);
  1482. end;
  1483. function TStringList.IndexOf(const S: string): Integer;
  1484. begin
  1485. Result := FMap.IndexOf(S);
  1486. end;
  1487. procedure TStringList.Insert(Index: Integer; const S: string);
  1488. begin
  1489. if not Sorted and (0 <= Index) and (Index < FMap.Count) then
  1490. Changing;
  1491. FMap.InsertKey(Index, S);
  1492. Changed;
  1493. end;
  1494. type
  1495. PStringList_CustomSort_Context = ^TStringList_CustomSort_Context;
  1496. TStringList_CustomSort_Context = record
  1497. List: TStringList;
  1498. ListStartPtr: Pointer;
  1499. ItemSize: SizeUInt;
  1500. IndexBase: Integer;
  1501. CompareFn: TStringListSortCompare;
  1502. end;
  1503. function TStringList_CustomSort_Comparer(Item1, Item2, Context: Pointer): Integer;
  1504. begin
  1505. with PStringList_CustomSort_Context(Context)^ do
  1506. Result := CompareFn(List,
  1507. ((Item1 - ListStartPtr) div ItemSize) + IndexBase,
  1508. ((Item2 - ListStartPtr) div ItemSize) + IndexBase);
  1509. end;
  1510. procedure TStringList_CustomSort_Exchanger(Item1, Item2, Context: Pointer);
  1511. begin
  1512. with PStringList_CustomSort_Context(Context)^ do
  1513. List.Exchange(((Item1 - ListStartPtr) div ItemSize) + IndexBase,
  1514. ((Item2 - ListStartPtr) div ItemSize) + IndexBase);
  1515. end;
  1516. procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
  1517. var
  1518. Context: TStringList_CustomSort_Context;
  1519. begin
  1520. if L > R then
  1521. exit;
  1522. Context.List := Self;
  1523. Context.ListStartPtr := FMap.Items[L];
  1524. Context.CompareFn := CompareFn;
  1525. Context.ItemSize := FMap.KeySize + FMap.DataSize;
  1526. Context.IndexBase := L;
  1527. DefaultSortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1528. Context.ListStartPtr, R - L + 1, Context.ItemSize, @TStringList_CustomSort_Comparer,
  1529. @TStringList_CustomSort_Exchanger, @Context);
  1530. end;
  1531. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  1532. begin
  1533. if not Sorted and (FMap.Count > 1) then
  1534. begin
  1535. Changing;
  1536. QuickSort(0, FMap.Count-1, CompareFn);
  1537. Changed;
  1538. end;
  1539. end;
  1540. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
  1541. var
  1542. Context: TStringList_CustomSort_Context;
  1543. begin
  1544. if not Sorted and (FMap.Count > 1) then
  1545. begin
  1546. Changing;
  1547. Context.List := Self;
  1548. Context.ListStartPtr := FMap.Items[0];
  1549. Context.CompareFn := CompareFn;
  1550. Context.ItemSize := FMap.KeySize + FMap.DataSize;
  1551. Context.IndexBase := 0;
  1552. SortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1553. Context.ListStartPtr, FMap.Count, Context.ItemSize, @TStringList_CustomSort_Comparer,
  1554. @TStringList_CustomSort_Exchanger, @Context);
  1555. Changed;
  1556. end;
  1557. end;
  1558. procedure TStringList.Sort;
  1559. begin
  1560. if not Sorted and (FMap.Count > 1) then
  1561. begin
  1562. Changing;
  1563. FMap.Sort;
  1564. Changed;
  1565. end;
  1566. end;
  1567. procedure TStringList.Sort(SortingAlgorithm: PSortingAlgorithm);
  1568. begin
  1569. if not Sorted and (FMap.Count > 1) then
  1570. begin
  1571. Changing;
  1572. FMap.Sort(SortingAlgorithm);
  1573. Changed;
  1574. end;
  1575. end;
  1576. {$endif}