stringl.inc 28 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548
  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; Quote : String) : String;
  35. Var
  36. I,J : Integer;
  37. begin
  38. J:=0;
  39. Result:=S;
  40. for i:=1to 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. FSpecialCharsInited:=true;
  64. FLBS:=DefaultTextLineBreakStyle;
  65. end;
  66. end;
  67. Function TStrings.GetLBS : TTextLineBreakStyle;
  68. begin
  69. CheckSpecialChars;
  70. Result:=FLBS;
  71. end;
  72. Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle);
  73. begin
  74. CheckSpecialChars;
  75. FLBS:=AValue;
  76. end;
  77. procedure TStrings.SetDelimiter(c:Char);
  78. begin
  79. CheckSpecialChars;
  80. FDelimiter:=c;
  81. end;
  82. procedure TStrings.SetQuoteChar(c:Char);
  83. begin
  84. CheckSpecialChars;
  85. FQuoteChar:=c;
  86. end;
  87. procedure TStrings.SetNameValueSeparator(c:Char);
  88. begin
  89. CheckSpecialChars;
  90. FNameValueSeparator:=c;
  91. end;
  92. function TStrings.GetCommaText: string;
  93. Var
  94. C1,C2 : Char;
  95. FSD : Boolean;
  96. begin
  97. CheckSpecialChars;
  98. FSD:=StrictDelimiter;
  99. C1:=Delimiter;
  100. C2:=QuoteChar;
  101. Delimiter:=',';
  102. QuoteChar:='"';
  103. StrictDelimiter:=False;
  104. Try
  105. Result:=GetDelimitedText;
  106. Finally
  107. Delimiter:=C1;
  108. QuoteChar:=C2;
  109. StrictDelimiter:=FSD;
  110. end;
  111. end;
  112. Function TStrings.GetDelimitedText: string;
  113. Var
  114. I : integer;
  115. p : pchar;
  116. c : set of char;
  117. S : String;
  118. begin
  119. CheckSpecialChars;
  120. result:='';
  121. if StrictDelimiter then
  122. c:=[#0,Delimiter]
  123. else
  124. c:=[#0..' ',QuoteChar,Delimiter];
  125. For i:=0 to count-1 do
  126. begin
  127. S:=Strings[i];
  128. p:=pchar(S);
  129. while not(p^ in c) do
  130. inc(p);
  131. // strings in list may contain #0
  132. if (p<>pchar(S)+length(S)) and not StrictDelimiter then
  133. Result:=Result+QuoteString(S,QuoteChar)
  134. else
  135. Result:=Result+S;
  136. if I<Count-1 then
  137. Result:=Result+Delimiter;
  138. end;
  139. If (Length(Result)=0) and (Count=1) then
  140. Result:=QuoteChar+QuoteChar;
  141. end;
  142. procedure TStrings.GetNameValue(Index : Integer; Out AName,AValue : String);
  143. Var L : longint;
  144. begin
  145. CheckSpecialChars;
  146. AValue:=Strings[Index];
  147. L:=Pos(FNameValueSeparator,AValue);
  148. If L<>0 then
  149. begin
  150. AName:=Copy(AValue,1,L-1);
  151. System.Delete(AValue,1,L);
  152. end
  153. else
  154. AName:='';
  155. end;
  156. function TStrings.ExtractName(const s:String):String;
  157. var
  158. L: Longint;
  159. begin
  160. CheckSpecialChars;
  161. L:=Pos(FNameValueSeparator,S);
  162. If L<>0 then
  163. Result:=Copy(S,1,L-1)
  164. else
  165. Result:='';
  166. end;
  167. function TStrings.GetName(Index: Integer): string;
  168. Var
  169. V : String;
  170. begin
  171. GetNameValue(Index,Result,V);
  172. end;
  173. Function TStrings.GetValue(const Name: string): string;
  174. Var
  175. L : longint;
  176. N : String;
  177. begin
  178. Result:='';
  179. L:=IndexOfName(Name);
  180. If L<>-1 then
  181. GetNameValue(L,N,Result);
  182. end;
  183. Function TStrings.GetValueFromIndex(Index: Integer): string;
  184. Var
  185. N : String;
  186. begin
  187. GetNameValue(Index,N,Result);
  188. end;
  189. Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string);
  190. begin
  191. If (Value='') then
  192. Delete(Index)
  193. else
  194. begin
  195. If (Index<0) then
  196. Index:=Add('');
  197. CheckSpecialChars;
  198. Strings[Index]:=GetName(Index)+FNameValueSeparator+Value;
  199. end;
  200. end;
  201. procedure TStrings.ReadData(Reader: TReader);
  202. begin
  203. Reader.ReadListBegin;
  204. BeginUpdate;
  205. try
  206. Clear;
  207. while not Reader.EndOfList do
  208. Add(Reader.ReadString);
  209. finally
  210. EndUpdate;
  211. end;
  212. Reader.ReadListEnd;
  213. end;
  214. Procedure TStrings.SetDelimitedText(const AValue: string);
  215. var i,j:integer;
  216. aNotFirst:boolean;
  217. begin
  218. CheckSpecialChars;
  219. BeginUpdate;
  220. i:=1;
  221. j:=1;
  222. aNotFirst:=false;
  223. try
  224. Clear;
  225. If StrictDelimiter then
  226. begin
  227. // Easier, faster loop.
  228. While I<=Length(AValue) do
  229. begin
  230. If (AValue[I] in [FDelimiter,#0]) then
  231. begin
  232. Add(Copy(AValue,J,I-J));
  233. J:=I+1;
  234. end;
  235. Inc(i);
  236. end;
  237. If (Length(AValue)>0) then
  238. Add(Copy(AValue,J,I-J));
  239. end
  240. else
  241. begin
  242. while i<=length(AValue) do begin
  243. // skip delimiter
  244. if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
  245. // skip spaces
  246. while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
  247. // read next string
  248. if i<=length(AValue) then begin
  249. if AValue[i]=FQuoteChar then begin
  250. // next string is quoted
  251. j:=i+1;
  252. while (j<=length(AValue)) and
  253. ( (AValue[j]<>FQuoteChar) or
  254. ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
  255. if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
  256. else inc(j);
  257. end;
  258. // j is position of closing quote
  259. Add( StringReplace (Copy(AValue,i+1,j-i-1),
  260. FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
  261. i:=j+1;
  262. end else begin
  263. // next string is not quoted
  264. j:=i;
  265. while (j<=length(AValue)) and
  266. (Ord(AValue[j])>Ord(' ')) and
  267. (AValue[j]<>FDelimiter) do inc(j);
  268. Add( Copy(AValue,i,j-i));
  269. i:=j;
  270. end;
  271. end else begin
  272. if aNotFirst then Add('');
  273. end;
  274. // skip spaces
  275. while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i);
  276. aNotFirst:=true;
  277. end;
  278. end;
  279. finally
  280. EndUpdate;
  281. end;
  282. end;
  283. Procedure TStrings.SetCommaText(const Value: string);
  284. Var
  285. C1,C2 : Char;
  286. begin
  287. CheckSpecialChars;
  288. C1:=Delimiter;
  289. C2:=QuoteChar;
  290. Delimiter:=',';
  291. QuoteChar:='"';
  292. Try
  293. SetDelimitedText(Value);
  294. Finally
  295. Delimiter:=C1;
  296. QuoteChar:=C2;
  297. end;
  298. end;
  299. Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
  300. begin
  301. end;
  302. Procedure TStrings.SetValue(const Name, Value: string);
  303. Var L : longint;
  304. begin
  305. CheckSpecialChars;
  306. L:=IndexOfName(Name);
  307. if L=-1 then
  308. Add (Name+FNameValueSeparator+Value)
  309. else
  310. Strings[L]:=Name+FNameValueSeparator+value;
  311. end;
  312. procedure TStrings.WriteData(Writer: TWriter);
  313. var
  314. i: Integer;
  315. begin
  316. Writer.WriteListBegin;
  317. for i := 0 to Count - 1 do
  318. Writer.WriteString(Strings[i]);
  319. Writer.WriteListEnd;
  320. end;
  321. procedure TStrings.DefineProperties(Filer: TFiler);
  322. var
  323. HasData: Boolean;
  324. begin
  325. if Assigned(Filer.Ancestor) then
  326. // Only serialize if string list is different from ancestor
  327. if Filer.Ancestor.InheritsFrom(TStrings) then
  328. HasData := not Equals(TStrings(Filer.Ancestor))
  329. else
  330. HasData := True
  331. else
  332. HasData := Count > 0;
  333. Filer.DefineProperty('Strings', @ReadData, @WriteData, HasData);
  334. end;
  335. Procedure TStrings.Error(const Msg: string; Data: Integer);
  336. begin
  337. Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
  338. end;
  339. Procedure TStrings.Error(const Msg: pstring; Data: Integer);
  340. begin
  341. Raise EStringListError.CreateFmt(Msg^,[Data]) at get_caller_addr(get_frame);
  342. end;
  343. Function TStrings.GetCapacity: Integer;
  344. begin
  345. Result:=Count;
  346. end;
  347. Function TStrings.GetObject(Index: Integer): TObject;
  348. begin
  349. Result:=Nil;
  350. end;
  351. Function TStrings.GetTextStr: string;
  352. Var P : Pchar;
  353. I,L,NLS : Longint;
  354. S,NL : String;
  355. begin
  356. CheckSpecialChars;
  357. // Determine needed place
  358. Case FLBS of
  359. tlbsLF : NL:=#10;
  360. tlbsCRLF : NL:=#13#10;
  361. tlbsCR : NL:=#13;
  362. end;
  363. L:=0;
  364. NLS:=Length(NL);
  365. For I:=0 to count-1 do
  366. L:=L+Length(Strings[I])+NLS;
  367. Setlength(Result,L);
  368. P:=Pointer(Result);
  369. For i:=0 To count-1 do
  370. begin
  371. S:=Strings[I];
  372. L:=Length(S);
  373. if L<>0 then
  374. System.Move(Pointer(S)^,P^,L);
  375. P:=P+L;
  376. For L:=1 to NLS do
  377. begin
  378. P^:=NL[L];
  379. inc(P);
  380. end;
  381. end;
  382. end;
  383. Procedure TStrings.Put(Index: Integer; const S: string);
  384. Var Obj : TObject;
  385. begin
  386. Obj:=Objects[Index];
  387. Delete(Index);
  388. InsertObject(Index,S,Obj);
  389. end;
  390. Procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  391. begin
  392. // Empty.
  393. end;
  394. Procedure TStrings.SetCapacity(NewCapacity: Integer);
  395. begin
  396. // Empty.
  397. end;
  398. Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
  399. Var
  400. PS : PChar;
  401. IP,L : Integer;
  402. begin
  403. L:=Length(Value);
  404. S:='';
  405. Result:=False;
  406. If ((L-P)<0) then
  407. exit;
  408. if ((L-P)=0) and (not (value[P] in [#10,#13])) Then
  409. Begin
  410. s:=value[P];
  411. inc(P);
  412. Exit(True);
  413. End;
  414. PS:=PChar(Value)+P-1;
  415. IP:=P;
  416. While ((L-P)>=0) and (not (PS^ in [#10,#13])) do
  417. begin
  418. P:=P+1;
  419. Inc(PS);
  420. end;
  421. SetLength (S,P-IP);
  422. System.Move (Value[IP],Pointer(S)^,P-IP);
  423. If (P<=L) and (Value[P]=#13) then
  424. Inc(P);
  425. If (P<=L) and (Value[P]=#10) then
  426. Inc(P); // Point to character after #10(#13)
  427. Result:=True;
  428. end;
  429. Procedure TStrings.SetTextStr(const Value: string);
  430. Var
  431. S : String;
  432. P : Integer;
  433. begin
  434. Try
  435. beginUpdate;
  436. Clear;
  437. P:=1;
  438. While GetNextLine (Value,S,P) do
  439. Add(S);
  440. finally
  441. EndUpdate;
  442. end;
  443. end;
  444. Procedure TStrings.SetUpdateState(Updating: Boolean);
  445. begin
  446. end;
  447. destructor TSTrings.Destroy;
  448. begin
  449. inherited destroy;
  450. end;
  451. Function TStrings.Add(const S: string): Integer;
  452. begin
  453. Result:=Count;
  454. Insert (Count,S);
  455. end;
  456. Function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  457. begin
  458. Result:=Add(S);
  459. Objects[result]:=AObject;
  460. end;
  461. Procedure TStrings.Append(const S: string);
  462. begin
  463. Add (S);
  464. end;
  465. Procedure TStrings.AddStrings(TheStrings: TStrings);
  466. Var Runner : longint;
  467. begin
  468. try
  469. beginupdate;
  470. For Runner:=0 to TheStrings.Count-1 do
  471. self.AddObject (Thestrings[Runner],TheStrings.Objects[Runner]);
  472. finally
  473. EndUpdate;
  474. end;
  475. end;
  476. Procedure TStrings.Assign(Source: TPersistent);
  477. Var
  478. S : TStrings;
  479. begin
  480. If Source is TStrings then
  481. begin
  482. S:=TStrings(Source);
  483. BeginUpdate;
  484. Try
  485. clear;
  486. FSpecialCharsInited:=S.FSpecialCharsInited;
  487. FQuoteChar:=S.FQuoteChar;
  488. FDelimiter:=S.FDelimiter;
  489. FNameValueSeparator:=S.FNameValueSeparator;
  490. FLBS:=S.FLBS;
  491. AddStrings(S);
  492. finally
  493. EndUpdate;
  494. end;
  495. end
  496. else
  497. Inherited Assign(Source);
  498. end;
  499. Procedure TStrings.BeginUpdate;
  500. begin
  501. if FUpdateCount = 0 then SetUpdateState(true);
  502. inc(FUpdateCount);
  503. end;
  504. Procedure TStrings.EndUpdate;
  505. begin
  506. If FUpdateCount>0 then
  507. Dec(FUpdateCount);
  508. if FUpdateCount=0 then
  509. SetUpdateState(False);
  510. end;
  511. Function TStrings.Equals(Obj: TObject): Boolean;
  512. begin
  513. if Obj is TStrings then
  514. Result := Equals(TStrings(Obj))
  515. else
  516. Result := inherited Equals(Obj);
  517. end;
  518. Function TStrings.Equals(TheStrings: TStrings): Boolean;
  519. Var Runner,Nr : Longint;
  520. begin
  521. Result:=False;
  522. Nr:=Self.Count;
  523. if Nr<>TheStrings.Count then exit;
  524. For Runner:=0 to Nr-1 do
  525. If Strings[Runner]<>TheStrings[Runner] then exit;
  526. Result:=True;
  527. end;
  528. Procedure TStrings.Exchange(Index1, Index2: Integer);
  529. Var
  530. Obj : TObject;
  531. Str : String;
  532. begin
  533. Try
  534. beginUpdate;
  535. Obj:=Objects[Index1];
  536. Str:=Strings[Index1];
  537. Objects[Index1]:=Objects[Index2];
  538. Strings[Index1]:=Strings[Index2];
  539. Objects[Index2]:=Obj;
  540. Strings[Index2]:=Str;
  541. finally
  542. EndUpdate;
  543. end;
  544. end;
  545. function TStrings.GetEnumerator: TStringsEnumerator;
  546. begin
  547. Result:=TStringsEnumerator.Create(Self);
  548. end;
  549. Function TStrings.GetText: PChar;
  550. begin
  551. Result:=StrNew(Pchar(Self.Text));
  552. end;
  553. Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt;
  554. begin
  555. result:=CompareText(s1,s2);
  556. end;
  557. Function TStrings.IndexOf(const S: string): Integer;
  558. begin
  559. Result:=0;
  560. While (Result<Count) and (DoCompareText(Strings[Result],S)<>0) do Result:=Result+1;
  561. if Result=Count then Result:=-1;
  562. end;
  563. Function TStrings.IndexOfName(const Name: string): Integer;
  564. Var
  565. len : longint;
  566. S : String;
  567. begin
  568. CheckSpecialChars;
  569. Result:=0;
  570. while (Result<Count) do
  571. begin
  572. S:=Strings[Result];
  573. len:=pos(FNameValueSeparator,S)-1;
  574. if (len>0) and (DoCompareText(Name,Copy(S,1,Len))=0) then
  575. exit;
  576. inc(result);
  577. end;
  578. result:=-1;
  579. end;
  580. Function TStrings.IndexOfObject(AObject: TObject): Integer;
  581. begin
  582. Result:=0;
  583. While (Result<count) and (Objects[Result]<>AObject) do Result:=Result+1;
  584. If Result=Count then Result:=-1;
  585. end;
  586. Procedure TStrings.InsertObject(Index: Integer; const S: string;
  587. AObject: TObject);
  588. begin
  589. Insert (Index,S);
  590. Objects[Index]:=AObject;
  591. end;
  592. Procedure TStrings.LoadFromFile(const FileName: string);
  593. Var
  594. TheStream : TFileStream;
  595. begin
  596. TheStream:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyWrite);
  597. try
  598. LoadFromStream(TheStream);
  599. finally
  600. TheStream.Free;
  601. end;
  602. end;
  603. Procedure TStrings.LoadFromStream(Stream: TStream);
  604. {
  605. Borlands method is no good, since a pipe for
  606. instance doesn't have a size.
  607. So we must do it the hard way.
  608. }
  609. Const
  610. BufSize = 1024;
  611. MaxGrow = 1 shl 29;
  612. Var
  613. Buffer : AnsiString;
  614. BytesRead,
  615. BufLen,
  616. I,BufDelta : Longint;
  617. begin
  618. // reread into a buffer
  619. try
  620. beginupdate;
  621. Buffer:='';
  622. BufLen:=0;
  623. I:=1;
  624. Repeat
  625. BufDelta:=BufSize*I;
  626. SetLength(Buffer,BufLen+BufDelta);
  627. BytesRead:=Stream.Read(Buffer[BufLen+1],BufDelta);
  628. inc(BufLen,BufDelta);
  629. If I<MaxGrow then
  630. I:=I shl 1;
  631. Until BytesRead<>BufDelta;
  632. SetLength(Buffer, BufLen-BufDelta+BytesRead);
  633. SetTextStr(Buffer);
  634. SetLength(Buffer,0);
  635. finally
  636. EndUpdate;
  637. end;
  638. end;
  639. Procedure TStrings.Move(CurIndex, NewIndex: Integer);
  640. Var
  641. Obj : TObject;
  642. Str : String;
  643. begin
  644. BeginUpdate;
  645. Obj:=Objects[CurIndex];
  646. Str:=Strings[CurIndex];
  647. Delete(Curindex);
  648. InsertObject(NewIndex,Str,Obj);
  649. EndUpdate;
  650. end;
  651. Procedure TStrings.SaveToFile(const FileName: string);
  652. Var TheStream : TFileStream;
  653. begin
  654. TheStream:=TFileStream.Create(FileName,fmCreate);
  655. try
  656. SaveToStream(TheStream);
  657. finally
  658. TheStream.Free;
  659. end;
  660. end;
  661. Procedure TStrings.SaveToStream(Stream: TStream);
  662. Var
  663. S : String;
  664. begin
  665. S:=Text;
  666. if S = '' then Exit;
  667. Stream.WriteBuffer(Pointer(S)^,Length(S));
  668. end;
  669. Procedure TStrings.SetText(TheText: PChar);
  670. Var S : String;
  671. begin
  672. If TheText<>Nil then
  673. S:=StrPas(TheText)
  674. else
  675. S:='';
  676. SetTextStr(S);
  677. end;
  678. {****************************************************************************}
  679. {* TStringList *}
  680. {****************************************************************************}
  681. {$if defined(VER2_0) or not defined(FPC_TESTGENERICS)}
  682. Procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  683. Var P1,P2 : Pointer;
  684. begin
  685. P1:=Pointer(Flist^[Index1].FString);
  686. P2:=Pointer(Flist^[Index1].FObject);
  687. Pointer(Flist^[Index1].Fstring):=Pointer(Flist^[Index2].Fstring);
  688. Pointer(Flist^[Index1].FObject):=Pointer(Flist^[Index2].FObject);
  689. Pointer(Flist^[Index2].Fstring):=P1;
  690. Pointer(Flist^[Index2].FObject):=P2;
  691. end;
  692. Procedure TStringList.Grow;
  693. Var
  694. NC : Integer;
  695. begin
  696. NC:=FCapacity;
  697. If NC>=256 then
  698. NC:=NC+(NC Div 4)
  699. else if NC=0 then
  700. NC:=4
  701. else
  702. NC:=NC*4;
  703. SetCapacity(NC);
  704. end;
  705. Procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
  706. var
  707. Pivot, vL, vR: Integer;
  708. begin
  709. if R - L <= 1 then begin // a little bit of time saver
  710. if L < R then
  711. if CompareFn(Self, L, R) > 0 then
  712. ExchangeItems(L, R);
  713. Exit;
  714. end;
  715. vL := L;
  716. vR := R;
  717. Pivot := L + Random(R - L); // they say random is best
  718. while vL < vR do begin
  719. while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do
  720. Inc(vL);
  721. while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
  722. Dec(vR);
  723. ExchangeItems(vL, vR);
  724. if Pivot = vL then // swap pivot if we just hit it from one side
  725. Pivot := vR
  726. else if Pivot = vR then
  727. Pivot := vL;
  728. end;
  729. if Pivot - 1 >= L then
  730. QuickSort(L, Pivot - 1, CompareFn);
  731. if Pivot + 1 <= R then
  732. QuickSort(Pivot + 1, R, CompareFn);
  733. end;
  734. Procedure TStringList.InsertItem(Index: Integer; const S: string);
  735. begin
  736. Changing;
  737. If FCount=Fcapacity then Grow;
  738. If Index<FCount then
  739. System.Move (FList^[Index],FList^[Index+1],
  740. (FCount-Index)*SizeOf(TStringItem));
  741. Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
  742. Flist^[Index].FString:=S;
  743. Flist^[Index].Fobject:=Nil;
  744. Inc(FCount);
  745. Changed;
  746. end;
  747. Procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject);
  748. begin
  749. Changing;
  750. If FCount=Fcapacity then Grow;
  751. If Index<FCount then
  752. System.Move (FList^[Index],FList^[Index+1],
  753. (FCount-Index)*SizeOf(TStringItem));
  754. Pointer(Flist^[Index].Fstring):=Nil; // Needed to initialize...
  755. Flist^[Index].FString:=S;
  756. Flist^[Index].FObject:=O;
  757. Inc(FCount);
  758. Changed;
  759. end;
  760. Procedure TStringList.SetSorted(Value: Boolean);
  761. begin
  762. If FSorted<>Value then
  763. begin
  764. If Value then sort;
  765. FSorted:=VAlue
  766. end;
  767. end;
  768. Procedure TStringList.Changed;
  769. begin
  770. If (FUpdateCount=0) Then
  771. If Assigned(FOnChange) then
  772. FOnchange(Self);
  773. end;
  774. Procedure TStringList.Changing;
  775. begin
  776. If FUpdateCount=0 then
  777. if Assigned(FOnChanging) then
  778. FOnchanging(Self);
  779. end;
  780. Function TStringList.Get(Index: Integer): string;
  781. begin
  782. If (Index<0) or (INdex>=Fcount) then
  783. Error (SListIndexError,Index);
  784. Result:=Flist^[Index].FString;
  785. end;
  786. Function TStringList.GetCapacity: Integer;
  787. begin
  788. Result:=FCapacity;
  789. end;
  790. Function TStringList.GetCount: Integer;
  791. begin
  792. Result:=FCount;
  793. end;
  794. Function TStringList.GetObject(Index: Integer): TObject;
  795. begin
  796. If (Index<0) or (INdex>=Fcount) then
  797. Error (SListIndexError,Index);
  798. Result:=Flist^[Index].FObject;
  799. end;
  800. Procedure TStringList.Put(Index: Integer; const S: string);
  801. begin
  802. If Sorted then
  803. Error(SSortedListError,0);
  804. If (Index<0) or (INdex>=Fcount) then
  805. Error (SListIndexError,Index);
  806. Changing;
  807. Flist^[Index].FString:=S;
  808. Changed;
  809. end;
  810. Procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  811. begin
  812. If (Index<0) or (INdex>=Fcount) then
  813. Error (SListIndexError,Index);
  814. Changing;
  815. Flist^[Index].FObject:=AObject;
  816. Changed;
  817. end;
  818. Procedure TStringList.SetCapacity(NewCapacity: Integer);
  819. Var NewList : Pointer;
  820. MSize : Longint;
  821. begin
  822. If (NewCapacity<0) then
  823. Error (SListCapacityError,NewCapacity);
  824. If NewCapacity>FCapacity then
  825. begin
  826. GetMem (NewList,NewCapacity*SizeOf(TStringItem));
  827. If NewList=Nil then
  828. Error (SListCapacityError,NewCapacity);
  829. If Assigned(FList) then
  830. begin
  831. MSize:=FCapacity*Sizeof(TStringItem);
  832. System.Move (FList^,NewList^,MSize);
  833. FillWord (Pchar(NewList)[MSize],(NewCapacity-FCapacity)*WordRatio, 0);
  834. FreeMem (Flist,MSize);
  835. end;
  836. Flist:=NewList;
  837. FCapacity:=NewCapacity;
  838. end
  839. else if NewCapacity<FCapacity then
  840. begin
  841. if NewCapacity = 0 then
  842. begin
  843. FreeMem(FList);
  844. FList := nil;
  845. end else
  846. begin
  847. GetMem(NewList, NewCapacity * SizeOf(TStringItem));
  848. System.Move(FList^, NewList^, NewCapacity * SizeOf(TStringItem));
  849. FreeMem(FList);
  850. FList := NewList;
  851. end;
  852. FCapacity:=NewCapacity;
  853. end;
  854. end;
  855. Procedure TStringList.SetUpdateState(Updating: Boolean);
  856. begin
  857. If Updating then
  858. Changing
  859. else
  860. Changed
  861. end;
  862. destructor TStringList.Destroy;
  863. Var I : Longint;
  864. begin
  865. FOnChange:=Nil;
  866. FOnChanging:=Nil;
  867. Clear;
  868. SetCapacity(0);
  869. Inherited destroy;
  870. end;
  871. Function TStringList.Add(const S: string): Integer;
  872. begin
  873. If Not Sorted then
  874. Result:=FCount
  875. else
  876. If Find (S,Result) then
  877. Case DUplicates of
  878. DupIgnore : Exit;
  879. DupError : Error(SDuplicateString,0)
  880. end;
  881. InsertItem (Result,S);
  882. end;
  883. Procedure TStringList.Clear;
  884. Var I : longint;
  885. begin
  886. if FCount = 0 then Exit;
  887. Changing;
  888. if FOwnsObjects then
  889. begin
  890. For I:=0 to FCount-1 do
  891. begin
  892. Flist^[I].FString:='';
  893. freeandnil(Flist^[i].FObject);
  894. end;
  895. end
  896. else
  897. begin
  898. For I:=0 to FCount-1 do
  899. Flist^[I].FString:='';
  900. end;
  901. FCount:=0;
  902. SetCapacity(0);
  903. Changed;
  904. end;
  905. Procedure TStringList.Delete(Index: Integer);
  906. begin
  907. If (Index<0) or (Index>=FCount) then
  908. Error(SlistINdexError,Index);
  909. Changing;
  910. Flist^[Index].FString:='';
  911. if FOwnsObjects then
  912. FreeAndNil(Flist^[Index].FObject);
  913. Dec(FCount);
  914. If Index<FCount then
  915. System.Move(Flist^[Index+1],
  916. Flist^[Index],
  917. (Fcount-Index)*SizeOf(TStringItem));
  918. Changed;
  919. end;
  920. Procedure TStringList.Exchange(Index1, Index2: Integer);
  921. begin
  922. If (Index1<0) or (Index1>=FCount) then
  923. Error(SListIndexError,Index1);
  924. If (Index2<0) or (Index2>=FCount) then
  925. Error(SListIndexError,Index2);
  926. Changing;
  927. ExchangeItems(Index1,Index2);
  928. changed;
  929. end;
  930. procedure TStringList.SetCaseSensitive(b : boolean);
  931. begin
  932. if b<>FCaseSensitive then
  933. begin
  934. FCaseSensitive:=b;
  935. if FSorted then
  936. sort;
  937. end;
  938. end;
  939. Function TStringList.DoCompareText(const s1,s2 : string) : PtrInt;
  940. begin
  941. if FCaseSensitive then
  942. result:=AnsiCompareStr(s1,s2)
  943. else
  944. result:=AnsiCompareText(s1,s2);
  945. end;
  946. Function TStringList.Find(const S: string; Out Index: Integer): Boolean;
  947. var
  948. L, R, I: Integer;
  949. CompareRes: PtrInt;
  950. begin
  951. Result := false;
  952. // Use binary search.
  953. L := 0;
  954. R := Count - 1;
  955. while (L<=R) do
  956. begin
  957. I := L + (R - L) div 2;
  958. CompareRes := DoCompareText(S, Flist^[I].FString);
  959. if (CompareRes>0) then
  960. L := I+1
  961. else begin
  962. R := I-1;
  963. if (CompareRes=0) then begin
  964. Result := true;
  965. if (Duplicates<>dupAccept) then
  966. L := I; // forces end of while loop
  967. end;
  968. end;
  969. end;
  970. Index := L;
  971. end;
  972. Function TStringList.IndexOf(const S: string): Integer;
  973. begin
  974. If Not Sorted then
  975. Result:=Inherited indexOf(S)
  976. else
  977. // faster using binary search...
  978. If Not Find (S,Result) then
  979. Result:=-1;
  980. end;
  981. Procedure TStringList.Insert(Index: Integer; const S: string);
  982. begin
  983. If Sorted then
  984. Error (SSortedListError,0)
  985. else
  986. If (Index<0) or (Index>FCount) then
  987. Error (SListIndexError,Index)
  988. else
  989. InsertItem (Index,S);
  990. end;
  991. Procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  992. begin
  993. If Not Sorted and (FCount>1) then
  994. begin
  995. Changing;
  996. QuickSort(0,FCount-1, CompareFn);
  997. Changed;
  998. end;
  999. end;
  1000. function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
  1001. begin
  1002. Result := List.DoCompareText(List.FList^[Index1].FString,
  1003. List.FList^[Index].FString);
  1004. end;
  1005. Procedure TStringList.Sort;
  1006. begin
  1007. CustomSort(@StringListAnsiCompare);
  1008. end;
  1009. {$else}
  1010. { generics based implementation of TStringList follows }
  1011. function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
  1012. begin
  1013. Result := List.DoCompareText(List.Strings[Index1], List.Strings[Index2]);
  1014. end;
  1015. constructor TStringList.Create;
  1016. begin
  1017. inherited;
  1018. FOwnsObjects:=false;
  1019. FMap := TFPStrObjMap.Create;
  1020. FMap.OnPtrCompare := @MapPtrCompare;
  1021. FOnCompareText := @DefaultCompareText;
  1022. CheckSpecialChars;
  1023. end;
  1024. destructor TStringList.Destroy;
  1025. begin
  1026. FMap.Free;
  1027. inherited;
  1028. end;
  1029. function TStringList.GetDuplicates: TDuplicates;
  1030. begin
  1031. Result := FMap.Duplicates;
  1032. end;
  1033. function TStringList.GetSorted: boolean;
  1034. begin
  1035. Result := FMap.Sorted;
  1036. end;
  1037. procedure TStringList.SetDuplicates(NewDuplicates: TDuplicates);
  1038. begin
  1039. FMap.Duplicates := NewDuplicates;
  1040. end;
  1041. procedure TStringList.SetSorted(NewSorted: Boolean);
  1042. begin
  1043. FMap.Sorted := NewSorted;
  1044. end;
  1045. procedure TStringList.Changed;
  1046. begin
  1047. if FUpdateCount = 0 then
  1048. if Assigned(FOnChange) then
  1049. FOnChange(Self);
  1050. end;
  1051. procedure TStringList.Changing;
  1052. begin
  1053. if FUpdateCount = 0 then
  1054. if Assigned(FOnChanging) then
  1055. FOnChanging(Self);
  1056. end;
  1057. function TStringList.Get(Index: Integer): string;
  1058. begin
  1059. Result := FMap.Keys[Index];
  1060. end;
  1061. function TStringList.GetCapacity: Integer;
  1062. begin
  1063. Result := FMap.Capacity;
  1064. end;
  1065. function TStringList.GetCount: Integer;
  1066. begin
  1067. Result := FMap.Count;
  1068. end;
  1069. function TStringList.GetObject(Index: Integer): TObject;
  1070. begin
  1071. Result := FMap.Data[Index];
  1072. end;
  1073. procedure TStringList.Put(Index: Integer; const S: string);
  1074. begin
  1075. Changing;
  1076. FMap.Keys[Index] := S;
  1077. Changed;
  1078. end;
  1079. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  1080. begin
  1081. Changing;
  1082. FMap.Data[Index] := AObject;
  1083. Changed;
  1084. end;
  1085. procedure TStringList.SetCapacity(NewCapacity: Integer);
  1086. begin
  1087. FMap.Capacity := NewCapacity;
  1088. end;
  1089. procedure TStringList.SetUpdateState(Updating: Boolean);
  1090. begin
  1091. if Updating then
  1092. Changing
  1093. else
  1094. Changed
  1095. end;
  1096. function TStringList.Add(const S: string): Integer;
  1097. begin
  1098. Result := FMap.Add(S);
  1099. end;
  1100. procedure TStringList.Clear;
  1101. begin
  1102. if FMap.Count = 0 then exit;
  1103. Changing;
  1104. FMap.Clear;
  1105. Changed;
  1106. end;
  1107. procedure TStringList.Delete(Index: Integer);
  1108. begin
  1109. if (Index < 0) or (Index >= FMap.Count) then
  1110. Error(SListIndexError, Index);
  1111. Changing;
  1112. FMap.Delete(Index);
  1113. Changed;
  1114. end;
  1115. procedure TStringList.Exchange(Index1, Index2: Integer);
  1116. begin
  1117. if (Index1 < 0) or (Index1 >= FMap.Count) then
  1118. Error(SListIndexError, Index1);
  1119. if (Index2 < 0) or (Index2 >= FMap.Count) then
  1120. Error(SListIndexError, Index2);
  1121. Changing;
  1122. FMap.InternalExchange(Index1, Index2);
  1123. Changed;
  1124. end;
  1125. procedure TStringList.SetCaseSensitive(NewSensitive: Boolean);
  1126. begin
  1127. if NewSensitive <> FCaseSensitive then
  1128. begin
  1129. FCaseSensitive := NewSensitive;
  1130. if Sorted then
  1131. Sort;
  1132. end;
  1133. end;
  1134. function TStringList.MapPtrCompare(Key1, Key2: Pointer): Integer;
  1135. begin
  1136. Result := FOnCompareText(string(Key1^), string(Key2^));
  1137. end;
  1138. function TStringList.DefaultCompareText(const s1, s2: string): PtrInt;
  1139. begin
  1140. if FCaseSensitive then
  1141. Result := AnsiCompareStr(s1, s2)
  1142. else
  1143. Result := AnsiCompareText(s1, s2);
  1144. end;
  1145. function TStringList.DoCompareText(const s1, s2: string): PtrInt;
  1146. begin
  1147. Result := FOnCompareText(s1, s2);
  1148. end;
  1149. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  1150. begin
  1151. Result := FMap.Find(S, Index);
  1152. end;
  1153. function TStringList.IndexOf(const S: string): Integer;
  1154. begin
  1155. Result := FMap.IndexOf(S);
  1156. end;
  1157. procedure TStringList.Insert(Index: Integer; const S: string);
  1158. begin
  1159. if not Sorted and (0 <= Index) and (Index < FMap.Count) then
  1160. Changing;
  1161. FMap.InsertKey(Index, S);
  1162. Changed;
  1163. end;
  1164. procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
  1165. var
  1166. I, J, Pivot: Integer;
  1167. begin
  1168. repeat
  1169. I := L;
  1170. J := R;
  1171. Pivot := (L + R) div 2;
  1172. repeat
  1173. while CompareFn(Self, I, Pivot) < 0 do Inc(I);
  1174. while CompareFn(Self, J, Pivot) > 0 do Dec(J);
  1175. if I <= J then
  1176. begin
  1177. FMap.InternalExchange(I, J); // No check, indices are correct.
  1178. if Pivot = I then
  1179. Pivot := J
  1180. else if Pivot = J then
  1181. Pivot := I;
  1182. Inc(I);
  1183. Dec(j);
  1184. end;
  1185. until I > J;
  1186. if L < J then
  1187. QuickSort(L,J, CompareFn);
  1188. L := I;
  1189. until I >= R;
  1190. end;
  1191. procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
  1192. begin
  1193. if not Sorted and (FMap.Count > 1) then
  1194. begin
  1195. Changing;
  1196. QuickSort(0, FMap.Count-1, CompareFn);
  1197. Changed;
  1198. end;
  1199. end;
  1200. procedure TStringList.Sort;
  1201. begin
  1202. if not Sorted and (FMap.Count > 1) then
  1203. begin
  1204. Changing;
  1205. FMap.Sort;
  1206. Changed;
  1207. end;
  1208. end;
  1209. {$endif}