stringl.inc 42 KB

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