stringl.inc 42 KB

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