stringl.inc 42 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040
  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. Procedure TStrings.LoadFromStream(Stream: TStream; IgnoreEncoding : Boolean);
  870. {
  871. Borlands method is no good, since a pipe for
  872. instance doesn't have a size.
  873. So we must do it the hard way.
  874. }
  875. Const
  876. BufSize = 1024;
  877. MaxGrow = 1 shl 29;
  878. Var
  879. Buffer : AnsiString;
  880. BytesRead,
  881. BufLen,
  882. I,BufDelta : SizeInt;
  883. begin
  884. if not IgnoreEncoding then
  885. begin
  886. LoadFromStream(Stream,Nil);
  887. Exit;
  888. end;
  889. // reread into a buffer
  890. beginupdate;
  891. try
  892. Buffer:='';
  893. BufLen:=0;
  894. I:=1;
  895. Repeat
  896. BufDelta:=BufSize*I;
  897. SetLength(Buffer,BufLen+BufDelta);
  898. BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta);
  899. inc(BufLen,BufDelta);
  900. If I<MaxGrow then
  901. I:=I shl 1;
  902. Until BytesRead<>BufDelta;
  903. SetLength(Buffer, BufLen-BufDelta+BytesRead);
  904. SetTextStr(Buffer);
  905. SetLength(Buffer,0);
  906. finally
  907. EndUpdate;
  908. end;
  909. end;
  910. Procedure TStrings.LoadFromStream(Stream: TStream; AEncoding: TEncoding);
  911. {
  912. Borlands method is no good, since a pipe for
  913. instance doesn't have a size.
  914. So we must do it the hard way.
  915. }
  916. Const
  917. BufSize = 1024;
  918. MaxGrow = 1 shl 29;
  919. Var
  920. Buffer : TBytes;
  921. T : string;
  922. BytesRead,
  923. BufLen,
  924. I,BufDelta: SizeInt;
  925. PreambleLength : Longint;
  926. begin
  927. // reread into a buffer
  928. beginupdate;
  929. try
  930. SetLength(Buffer,0);
  931. BufLen:=0;
  932. I:=1;
  933. Repeat
  934. BufDelta:=BufSize*I;
  935. SetLength(Buffer,BufLen+BufDelta);
  936. BytesRead:=Stream.Read(Buffer[BufLen],BufDelta);
  937. inc(BufLen,BufDelta);
  938. If I<MaxGrow then
  939. I:=I shl 1;
  940. Until BytesRead<>BufDelta;
  941. SetLength(Buffer,BufLen-BufDelta+BytesRead);
  942. PreambleLength:=TEncoding.GetBufferEncoding(Buffer,AEncoding,FDefaultEncoding);
  943. T:=AEncoding.GetAnsiString(Buffer,PreambleLength,Length(Buffer)-PreambleLength);
  944. SetEncoding(AEncoding);
  945. SetLength(Buffer,0);
  946. SetTextStr(T);
  947. finally
  948. EndUpdate;
  949. end;
  950. end;
  951. Procedure TStrings.Move(CurIndex, NewIndex: Integer);
  952. Var
  953. Obj : TObject;
  954. Str : String;
  955. begin
  956. BeginUpdate;
  957. Try
  958. Obj:=Objects[CurIndex];
  959. Str:=Strings[CurIndex];
  960. Objects[CurIndex]:=Nil; // Prevent Delete from freeing.
  961. Delete(Curindex);
  962. InsertObject(NewIndex,Str,Obj);
  963. finally
  964. EndUpdate;
  965. end;
  966. end;
  967. Procedure TStrings.SaveToFile(const FileName: string);
  968. Var TheStream : TFileStream;
  969. begin
  970. TheStream:=TFileStream.Create(FileName,fmCreate);
  971. try
  972. SaveToStream(TheStream);
  973. finally
  974. TheStream.Free;
  975. end;
  976. end;
  977. Procedure TStrings.SaveToFile(const FileName: string; AEncoding: TEncoding);
  978. Var TheStream : TFileStream;
  979. begin
  980. TheStream:=TFileStream.Create(FileName,fmCreate);
  981. try
  982. SaveToStream(TheStream,AEncoding);
  983. finally
  984. TheStream.Free;
  985. end;
  986. end;
  987. Procedure TStrings.SaveToStream(Stream: TStream);
  988. Var
  989. S : String;
  990. begin
  991. if Encoding<>nil then
  992. SaveToStream(Stream,Encoding)
  993. else
  994. begin
  995. S:=Text;
  996. if S = '' then Exit;
  997. Stream.WriteBuffer(Pointer(S)^,Length(S));
  998. end;
  999. end;
  1000. Procedure TStrings.SaveToStream(Stream: TStream; AEncoding: TEncoding);
  1001. Var B : TBytes;
  1002. begin
  1003. if AEncoding=nil then
  1004. AEncoding:=FDefaultEncoding;
  1005. if FWriteBOM then
  1006. begin
  1007. B:=AEncoding.GetPreamble;
  1008. if Length(B)>0 then
  1009. Stream.WriteBuffer(B[0],Length(B));
  1010. end;
  1011. B:=AEncoding.GetAnsiBytes(Text);
  1012. if Length(B)>0 then
  1013. Stream.WriteBuffer(B[0],Length(B));
  1014. end;
  1015. Procedure TStrings.SetText(TheText: PChar);
  1016. Var S : String;
  1017. begin
  1018. If TheText<>Nil then
  1019. S:=StrPas(TheText)
  1020. else
  1021. S:='';
  1022. SetTextStr(S);
  1023. end;
  1024. {****************************************************************************}
  1025. {* TStringList *}
  1026. {****************************************************************************}
  1027. {$if not defined(FPC_TESTGENERICS)}
  1028. procedure TStringList.ExchangeItemsInt(Index1, Index2: Integer);
  1029. Var P1,P2 : Pointer;
  1030. begin
  1031. P1:=Pointer(Flist^[Index1].FString);
  1032. P2:=Pointer(Flist^[Index1].FObject);
  1033. Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring);
  1034. Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject);
  1035. Pointer(Flist^[Index2].Fstring):=P1;
  1036. Pointer(Flist^[Index2].FObject):=P2;
  1037. end;
  1038. function TStringList.GetSorted: Boolean;
  1039. begin
  1040. Result:=FSortStyle in [sslUser,sslAuto];
  1041. end;
  1042. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  1043. begin
  1044. ExchangeItemsInt(Index1, Index2);
  1045. end;
  1046. procedure TStringList.Grow;
  1047. Var
  1048. NC : Integer;
  1049. begin
  1050. NC:=FCapacity;
  1051. If NC>=256 then
  1052. NC:=NC+(NC Div 4)
  1053. else if NC=0 then
  1054. NC:=4
  1055. else
  1056. NC:=NC*4;
  1057. SetCapacity(NC);
  1058. end;
  1059. procedure TStringList.InternalClear(FromIndex: Integer; ClearOnly: Boolean);
  1060. Var
  1061. I: Integer;
  1062. begin
  1063. if FromIndex < FCount then
  1064. begin
  1065. if FOwnsObjects then
  1066. begin
  1067. For I:=FromIndex to FCount-1 do
  1068. begin
  1069. Flist^[I].FString:='';
  1070. freeandnil(Flist^[i].FObject);
  1071. end;
  1072. end
  1073. else
  1074. begin
  1075. For I:=FromIndex to FCount-1 do
  1076. Flist^[I].FString:='';
  1077. end;
  1078. FCount:=FromIndex;
  1079. end;
  1080. if Not ClearOnly then
  1081. SetCapacity(0);
  1082. end;
  1083. procedure TStringList.InsertItem(Index: Integer; const S: string);
  1084. begin
  1085. InsertItem(Index, S, nil);
  1086. end;
  1087. procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject);
  1088. begin
  1089. Changing;
  1090. If FCount=Fcapacity then Grow;
  1091. If Index<FCount then
  1092. System.Move (FList^[Index],FList^[Index+1],
  1093. (FCount-Index)*SizeOf(TStringItem));
  1094. Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
  1095. Flist^[Index].FString:=S;
  1096. Flist^[Index].FObject:=O;
  1097. Inc(FCount);
  1098. Changed;
  1099. end;
  1100. procedure TStringList.SetSorted(Value: Boolean);
  1101. begin
  1102. If Value then
  1103. SortStyle:=sslAuto
  1104. else
  1105. SortStyle:=sslNone
  1106. end;
  1107. procedure TStringList.Changed;
  1108. begin
  1109. If (FUpdateCount=0) Then
  1110. begin
  1111. If Assigned(FOnChange) then
  1112. FOnchange(Self);
  1113. FPONotifyObservers(Self,ooChange,Nil);
  1114. end;
  1115. end;
  1116. procedure TStringList.Changing;
  1117. begin
  1118. If FUpdateCount=0 then
  1119. if Assigned(FOnChanging) then
  1120. FOnchanging(Self);
  1121. end;
  1122. function TStringList.Get(Index: Integer): string;
  1123. begin
  1124. CheckIndex(Index);
  1125. Result:=Flist^[Index].FString;
  1126. end;
  1127. function TStringList.GetCapacity: Integer;
  1128. begin
  1129. Result:=FCapacity;
  1130. end;
  1131. function TStringList.GetCount: Integer;
  1132. begin
  1133. Result:=FCount;
  1134. end;
  1135. function TStringList.GetObject(Index: Integer): TObject;
  1136. begin
  1137. CheckIndex(Index);
  1138. Result:=Flist^[Index].FObject;
  1139. end;
  1140. procedure TStringList.Put(Index: Integer; const S: string);
  1141. begin
  1142. If Sorted then
  1143. Error(SSortedListError,0);
  1144. CheckIndex(Index);
  1145. Changing;
  1146. Flist^[Index].FString:=S;
  1147. Changed;
  1148. end;
  1149. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  1150. begin
  1151. CheckIndex(Index);
  1152. Changing;
  1153. Flist^[Index].FObject:=AObject;
  1154. Changed;
  1155. end;
  1156. procedure TStringList.SetCapacity(NewCapacity: Integer);
  1157. Var NewList : Pointer;
  1158. MSize : Longint;
  1159. begin
  1160. If (NewCapacity<0) then
  1161. Error (SListCapacityError,NewCapacity);
  1162. If NewCapacity>FCapacity then
  1163. begin
  1164. GetMem (NewList,NewCapacity*SizeOf(TStringItem));
  1165. If NewList=Nil then
  1166. Error (SListCapacityError,NewCapacity);
  1167. If Assigned(FList) then
  1168. begin
  1169. MSize:=FCapacity*Sizeof(TStringItem);
  1170. System.Move (FList^,NewList^,MSize);
  1171. FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*(SizeOf(TStringItem) div SizeOf(Word)), 0);
  1172. FreeMem (Flist,MSize);
  1173. end;
  1174. Flist:=NewList;
  1175. FCapacity:=NewCapacity;
  1176. end
  1177. else if NewCapacity<FCapacity then
  1178. begin
  1179. if NewCapacity = 0 then
  1180. begin
  1181. if FCount > 0 then
  1182. InternalClear(0,True);
  1183. FreeMem(FList);
  1184. FList := nil;
  1185. end else
  1186. begin
  1187. InternalClear(NewCapacity,True);
  1188. GetMem(NewList, NewCapacity * SizeOf(TStringItem));
  1189. System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
  1190. FreeMem(FList);
  1191. FList := NewList;
  1192. end;
  1193. FCapacity:=NewCapacity;
  1194. end;
  1195. end;
  1196. procedure TStringList.SetUpdateState(Updating: Boolean);
  1197. begin
  1198. If Updating then
  1199. Changing
  1200. else
  1201. Changed
  1202. end;
  1203. destructor TStringList.Destroy;
  1204. begin
  1205. InternalClear;
  1206. Inherited destroy;
  1207. end;
  1208. function TStringList.Add(const S: string): Integer;
  1209. begin
  1210. If Not (SortStyle=sslAuto) then
  1211. Result:=FCount
  1212. else
  1213. If Find (S,Result) then
  1214. Case DUplicates of
  1215. DupIgnore : Exit;
  1216. DupError : Error(SDuplicateString,0)
  1217. end;
  1218. InsertItem (Result,S);
  1219. end;
  1220. procedure TStringList.Clear;
  1221. begin
  1222. if FCount = 0 then Exit;
  1223. Changing;
  1224. InternalClear;
  1225. Changed;
  1226. end;
  1227. procedure TStringList.Delete(Index: Integer);
  1228. begin
  1229. CheckIndex(Index);
  1230. Changing;
  1231. Flist^[Index].FString:='';
  1232. if FOwnsObjects then
  1233. FreeAndNil(Flist^[Index].FObject);
  1234. Dec(FCount);
  1235. If Index<FCount then
  1236. System.Move(Flist^[Index+1],
  1237. Flist^[Index],
  1238. (Fcount-Index)*SizeOf(TStringItem));
  1239. Changed;
  1240. end;
  1241. procedure TStringList.Exchange(Index1, Index2: Integer);
  1242. begin
  1243. CheckIndex(Index1);
  1244. CheckIndex(Index2);
  1245. Changing;
  1246. ExchangeItemsInt(Index1,Index2);
  1247. changed;
  1248. end;
  1249. procedure TStringList.SetCaseSensitive(b : boolean);
  1250. begin
  1251. if b=FCaseSensitive then
  1252. Exit;
  1253. FCaseSensitive:=b;
  1254. if FSortStyle=sslAuto then
  1255. begin
  1256. FForceSort:=True;
  1257. try
  1258. Sort;
  1259. finally
  1260. FForceSort:=False;
  1261. end;
  1262. end;
  1263. end;
  1264. procedure TStringList.SetSortStyle(AValue: TStringsSortStyle);
  1265. begin
  1266. if FSortStyle=AValue then Exit;
  1267. if (AValue=sslAuto) then
  1268. Sort;
  1269. FSortStyle:=AValue;
  1270. end;
  1271. procedure TStringList.CheckIndex(AIndex: Integer);
  1272. begin
  1273. If (AIndex<0) or (AIndex>=FCount) then
  1274. Error(SListIndexError,AIndex);
  1275. end;
  1276. function TStringList.DoCompareText(const s1, s2: string): PtrInt;
  1277. begin
  1278. if FCaseSensitive then
  1279. result:=AnsiCompareStr(s1,s2)
  1280. else
  1281. result:=AnsiCompareText(s1,s2);
  1282. end;
  1283. function TStringList.CompareStrings(const s1,s2 : string) : Integer;
  1284. begin
  1285. Result := DoCompareText(s1, s2);
  1286. end;
  1287. function TStringList.Find(const S: string; out Index: Integer): Boolean;
  1288. var
  1289. L, R, I: Integer;
  1290. CompareRes: PtrInt;
  1291. begin
  1292. Result := false;
  1293. Index:=-1;
  1294. if Not Sorted then
  1295. Raise EListError.Create(SErrFindNeedsSortedList);
  1296. // Use binary search.
  1297. L := 0;
  1298. R := Count - 1;
  1299. while (L<=R) do
  1300. begin
  1301. I := L + (R - L) div 2;
  1302. CompareRes := DoCompareText(S, Flist^[I].FString);
  1303. if (CompareRes>0) then
  1304. L := I+1
  1305. else begin
  1306. R := I-1;
  1307. if (CompareRes=0) then begin
  1308. Result := true;
  1309. if (Duplicates<>dupAccept) then
  1310. L := I; // forces end of while loop
  1311. end;
  1312. end;
  1313. end;
  1314. Index := L;
  1315. end;
  1316. function TStringList.IndexOf(const S: string): Integer;
  1317. begin
  1318. If Not Sorted then
  1319. Result:=Inherited indexOf(S)
  1320. else
  1321. // faster using binary search...
  1322. If Not Find (S,Result) then
  1323. Result:=-1;
  1324. end;
  1325. procedure TStringList.Insert(Index: Integer; const S: string);
  1326. begin
  1327. If SortStyle=sslAuto then
  1328. Error (SSortedListError,0)
  1329. else
  1330. begin
  1331. If (Index<0) or (Index>FCount) then
  1332. Error(SListIndexError,Index); // Cannot use CheckIndex, because there >= FCount...
  1333. InsertItem (Index,S);
  1334. end;
  1335. end;
  1336. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  1337. begin
  1338. CustomSort(CompareFn, SortBase.DefaultSortingAlgorithm);
  1339. end;
  1340. type
  1341. PStringList_CustomSort_Context = ^TStringList_CustomSort_Context;
  1342. TStringList_CustomSort_Context = record
  1343. List: TStringList;
  1344. ListStartPtr: Pointer;
  1345. CompareFn: TStringListSortCompare;
  1346. end;
  1347. function TStringList_CustomSort_Comparer(Item1, Item2, Context: Pointer): Integer;
  1348. begin
  1349. with PStringList_CustomSort_Context(Context)^ do
  1350. Result := CompareFn(List,
  1351. (Item1 - ListStartPtr) div SizeOf(TStringItem),
  1352. (Item2 - ListStartPtr) div SizeOf(TStringItem));
  1353. end;
  1354. procedure TStringList_CustomSort_Exchanger(Item1, Item2, Context: Pointer);
  1355. begin
  1356. with PStringList_CustomSort_Context(Context)^ do
  1357. List.ExchangeItems((Item1 - ListStartPtr) div SizeOf(TStringItem),
  1358. (Item2 - ListStartPtr) div SizeOf(TStringItem));
  1359. end;
  1360. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
  1361. var
  1362. Context: TStringList_CustomSort_Context;
  1363. begin
  1364. If (FForceSort or (Not (FSortStyle=sslAuto))) and (FCount>1) then
  1365. begin
  1366. Changing;
  1367. Context.List := Self;
  1368. Context.ListStartPtr := FList;
  1369. Context.CompareFn := CompareFn;
  1370. //if ExchangeItems is overriden call that, else call (faster) ItemListSorter_ContextComparer
  1371. if TMethod(@Self.ExchangeItems).Code = CodePointer(@TStringList.ExchangeItems) then
  1372. SortingAlgorithm^.ItemListSorter_ContextComparer(
  1373. FList, FCount, SizeOf(TStringItem), @TStringList_CustomSort_Comparer,
  1374. @Context)
  1375. else
  1376. SortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1377. FList, FCount, SizeOf(TStringItem), @TStringList_CustomSort_Comparer,
  1378. @TStringList_CustomSort_Exchanger, @Context);
  1379. Changed;
  1380. end;
  1381. end;
  1382. function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
  1383. begin
  1384. Result := List.DoCompareText(List.FList^[Index1].FString,
  1385. List.FList^[Index].FString);
  1386. end;
  1387. procedure TStringList.Sort;
  1388. begin
  1389. CustomSort(@StringListAnsiCompare);
  1390. end;
  1391. procedure TStringList.Sort(SortingAlgorithm: PSortingAlgorithm);
  1392. begin
  1393. CustomSort(@StringListAnsiCompare, SortingAlgorithm);
  1394. end;
  1395. {$else}
  1396. { generics based implementation of TStringList follows }
  1397. function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
  1398. begin
  1399. Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]);
  1400. end;
  1401. constructor TStringList.Create;
  1402. begin
  1403. inherited;
  1404. FOwnsObjects:=false;
  1405. FMap := TFPStrObjMap.Create;
  1406. FMap.OnPtrCompare := @MapPtrCompare;
  1407. FOnCompareText := @DefaultCompareText;
  1408. NameValueSeparator:='=';
  1409. CheckSpecialChars;
  1410. end;
  1411. destructor TStringList.Destroy;
  1412. begin
  1413. FMap.Free;
  1414. inherited;
  1415. end;
  1416. function TStringList.GetDuplicates: TDuplicates;
  1417. begin
  1418. Result := FMap.Duplicates;
  1419. end;
  1420. function TStringList.GetSorted: boolean;
  1421. begin
  1422. Result := FMap.Sorted;
  1423. end;
  1424. procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates);
  1425. begin
  1426. FMap.Duplicates := NewDuplicates;
  1427. end;
  1428. procedure TStringList.SetSorted(NewSorted: Boolean);
  1429. begin
  1430. FMap.Sorted := NewSorted;
  1431. end;
  1432. procedure TStringList.Changed;
  1433. begin
  1434. if FUpdateCount = 0 then
  1435. if Assigned(FOnChange) then
  1436. FOnChange(Self);
  1437. end;
  1438. procedure TStringList.Changing;
  1439. begin
  1440. if FUpdateCount = 0 then
  1441. if Assigned(FOnChanging) then
  1442. FOnChanging(Self);
  1443. end;
  1444. function TStringList.Get(Index: Integer): string;
  1445. begin
  1446. Result := FMap.Keys[Index];
  1447. end;
  1448. function TStringList.GetCapacity: Integer;
  1449. begin
  1450. Result := FMap.Capacity;
  1451. end;
  1452. function TStringList.GetCount: Integer;
  1453. begin
  1454. Result := FMap.Count;
  1455. end;
  1456. function TStringList.GetObject(Index: Integer): TObject;
  1457. begin
  1458. Result := FMap.Data[Index];
  1459. end;
  1460. procedure TStringList.Put(Index: Integer; const S: string);
  1461. begin
  1462. Changing;
  1463. FMap.Keys[Index] := S;
  1464. Changed;
  1465. end;
  1466. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  1467. begin
  1468. Changing;
  1469. FMap.Data[Index] := AObject;
  1470. Changed;
  1471. end;
  1472. procedure TStringList.SetCapacity(NewCapacity: Integer);
  1473. begin
  1474. FMap.Capacity := NewCapacity;
  1475. end;
  1476. procedure TStringList.SetUpdateState(Updating: Boolean);
  1477. begin
  1478. if Updating then
  1479. Changing
  1480. else
  1481. Changed
  1482. end;
  1483. function TStringList.Add(const S: string): Integer;
  1484. begin
  1485. Result := FMap.Add(S);
  1486. end;
  1487. procedure TStringList.Clear;
  1488. begin
  1489. if FMap.Count = 0 then exit;
  1490. Changing;
  1491. FMap.Clear;
  1492. Changed;
  1493. end;
  1494. procedure TStringList.Delete(Index: Integer);
  1495. begin
  1496. if (Index < 0) or (Index >= FMap.Count) then
  1497. Error(SListIndexError, Index);
  1498. Changing;
  1499. FMap.Delete(Index);
  1500. Changed;
  1501. end;
  1502. procedure TStringList.Exchange(Index1, Index2: Integer);
  1503. begin
  1504. if (Index1 < 0) or (Index1 >= FMap.Count) then
  1505. Error(SListIndexError, Index1);
  1506. if (Index2 < 0) or (Index2 >= FMap.Count) then
  1507. Error(SListIndexError, Index2);
  1508. Changing;
  1509. FMap.InternalExchange(Index1, Index2);
  1510. Changed;
  1511. end;
  1512. procedure TStringList.SetCaseSensitive(NewSensitive: Boolean);
  1513. begin
  1514. if NewSensitive <> FCaseSensitive then
  1515. begin
  1516. FCaseSensitive := NewSensitive;
  1517. if Sorted then
  1518. Sort;
  1519. end;
  1520. end;
  1521. function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer;
  1522. begin
  1523. Result := FOnCompareText(string(Key1^), string(Key2^));
  1524. end;
  1525. function TStringList.DefaultCompareText(const s1, s2: string): PtrInt;
  1526. begin
  1527. if FCaseSensitive then
  1528. Result := AnsiCompareStr(s1, s2)
  1529. else
  1530. Result := AnsiCompareText(s1, s2);
  1531. end;
  1532. function TStringList.DoCompareText(const s1, s2: string): PtrInt;
  1533. begin
  1534. Result := FOnCompareText(s1, s2);
  1535. end;
  1536. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  1537. begin
  1538. Result := FMap.Find(S, Index);
  1539. end;
  1540. function TStringList.IndexOf(const S: string): Integer;
  1541. begin
  1542. Result := FMap.IndexOf(S);
  1543. end;
  1544. procedure TStringList.Insert(Index: Integer; const S: string);
  1545. begin
  1546. if not Sorted and (0 <= Index) and (Index < FMap.Count) then
  1547. Changing;
  1548. FMap.InsertKey(Index, S);
  1549. Changed;
  1550. end;
  1551. type
  1552. PStringList_CustomSort_Context = ^TStringList_CustomSort_Context;
  1553. TStringList_CustomSort_Context = record
  1554. List: TStringList;
  1555. ListStartPtr: Pointer;
  1556. ItemSize: SizeUInt;
  1557. IndexBase: Integer;
  1558. CompareFn: TStringListSortCompare;
  1559. end;
  1560. function TStringList_CustomSort_Comparer(Item1, Item2, Context: Pointer): Integer;
  1561. begin
  1562. with PStringList_CustomSort_Context(Context)^ do
  1563. Result := CompareFn(List,
  1564. ((Item1 - ListStartPtr) div ItemSize) + IndexBase,
  1565. ((Item2 - ListStartPtr) div ItemSize) + IndexBase);
  1566. end;
  1567. procedure TStringList_CustomSort_Exchanger(Item1, Item2, Context: Pointer);
  1568. begin
  1569. with PStringList_CustomSort_Context(Context)^ do
  1570. List.Exchange(((Item1 - ListStartPtr) div ItemSize) + IndexBase,
  1571. ((Item2 - ListStartPtr) div ItemSize) + IndexBase);
  1572. end;
  1573. procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
  1574. var
  1575. Context: TStringList_CustomSort_Context;
  1576. begin
  1577. if L > R then
  1578. exit;
  1579. Context.List := Self;
  1580. Context.ListStartPtr := FMap.Items[L];
  1581. Context.CompareFn := CompareFn;
  1582. Context.ItemSize := FMap.KeySize + FMap.DataSize;
  1583. Context.IndexBase := L;
  1584. DefaultSortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1585. Context.ListStartPtr, R - L + 1, Context.ItemSize, @TStringList_CustomSort_Comparer,
  1586. @TStringList_CustomSort_Exchanger, @Context);
  1587. end;
  1588. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  1589. begin
  1590. if not Sorted and (FMap.Count > 1) then
  1591. begin
  1592. Changing;
  1593. QuickSort(0, FMap.Count-1, CompareFn);
  1594. Changed;
  1595. end;
  1596. end;
  1597. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
  1598. var
  1599. Context: TStringList_CustomSort_Context;
  1600. begin
  1601. if not Sorted and (FMap.Count > 1) then
  1602. begin
  1603. Changing;
  1604. Context.List := Self;
  1605. Context.ListStartPtr := FMap.Items[0];
  1606. Context.CompareFn := CompareFn;
  1607. Context.ItemSize := FMap.KeySize + FMap.DataSize;
  1608. Context.IndexBase := 0;
  1609. SortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
  1610. Context.ListStartPtr, FMap.Count, Context.ItemSize, @TStringList_CustomSort_Comparer,
  1611. @TStringList_CustomSort_Exchanger, @Context);
  1612. Changed;
  1613. end;
  1614. end;
  1615. procedure TStringList.Sort;
  1616. begin
  1617. if not Sorted and (FMap.Count > 1) then
  1618. begin
  1619. Changing;
  1620. FMap.Sort;
  1621. Changed;
  1622. end;
  1623. end;
  1624. procedure TStringList.Sort(SortingAlgorithm: PSortingAlgorithm);
  1625. begin
  1626. if not Sorted and (FMap.Count > 1) then
  1627. begin
  1628. Changing;
  1629. FMap.Sort(SortingAlgorithm);
  1630. Changed;
  1631. end;
  1632. end;
  1633. {$endif}