sysstr.inc 70 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810
  1. {
  2. *********************************************************************
  3. Copyright (C) 1997, 1998 Gertjan Schouten
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. *********************************************************************
  16. System Utilities For Free Pascal
  17. }
  18. { NewStr creates a new PString and assigns S to it
  19. if length(s) = 0 NewStr returns Nil }
  20. function NewStr(const S: string): PString;
  21. begin
  22. if (S='') then
  23. Result:=nil
  24. else
  25. begin
  26. new(result);
  27. if (Result<>nil) then
  28. Result^:=s;
  29. end;
  30. end;
  31. { DisposeStr frees the memory occupied by S }
  32. procedure DisposeStr(S: PString);
  33. begin
  34. if S <> Nil then
  35. begin
  36. dispose(s);
  37. S:=nil;
  38. end;
  39. end;
  40. { AssignStr assigns S to P^ }
  41. procedure AssignStr(var P: PString; const S: string);
  42. begin
  43. P^ := s;
  44. end ;
  45. { AppendStr appends S to Dest }
  46. procedure AppendStr(var Dest: String; const S: string);
  47. begin
  48. Dest := Dest + S;
  49. end ;
  50. { UpperCase returns a copy of S where all lowercase characters ( from a to z )
  51. have been converted to uppercase }
  52. Function UpperCase(Const S : String) : String;
  53. Var
  54. i : Integer;
  55. P : PChar;
  56. begin
  57. Result := S;
  58. UniqueString(Result);
  59. P:=Pchar(Result);
  60. for i := 1 to Length(Result) do
  61. begin
  62. if (P^ in ['a'..'z']) then P^ := char(byte(p^) - 32);
  63. Inc(P);
  64. end;
  65. end;
  66. { LowerCase returns a copy of S where all uppercase characters ( from A to Z )
  67. have been converted to lowercase }
  68. Function Lowercase(Const S : String) : String;
  69. Var
  70. i : Integer;
  71. P : PChar;
  72. begin
  73. Result := S;
  74. UniqueString(Result);
  75. P:=Pchar(Result);
  76. for i := 1 to Length(Result) do
  77. begin
  78. if (P^ in ['A'..'Z']) then P^ := char(byte(p^) + 32);
  79. Inc(P);
  80. end;
  81. end;
  82. function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
  83. begin
  84. result:=LowerCase(ansistring(V));
  85. end;
  86. { CompareStr compares S1 and S2, the result is the based on
  87. substraction of the ascii values of the characters in S1 and S2
  88. case result
  89. S1 < S2 < 0
  90. S1 > S2 > 0
  91. S1 = S2 = 0 }
  92. function CompareStr(const S1, S2: string): Integer;
  93. var count, count1, count2: integer;
  94. begin
  95. result := 0;
  96. Count1 := Length(S1);
  97. Count2 := Length(S2);
  98. if Count1>Count2 then
  99. Count:=Count2
  100. else
  101. Count:=Count1;
  102. result := CompareMemRange(Pointer(S1),Pointer(S2), Count);
  103. if result=0 then
  104. result:=Count1-Count2;
  105. end;
  106. { CompareMemRange returns the result of comparison of Length bytes at P1 and P2
  107. case result
  108. P1 < P2 < 0
  109. P1 > P2 > 0
  110. P1 = P2 = 0 }
  111. function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer;
  112. var
  113. i: cardinal;
  114. begin
  115. i := 0;
  116. result := 0;
  117. while (result=0) and (I<length) do
  118. begin
  119. result:=byte(P1^)-byte(P2^);
  120. P1:=pchar(P1)+1; // VP compat.
  121. P2:=pchar(P2)+1;
  122. i := i + 1;
  123. end ;
  124. end ;
  125. function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean;
  126. var
  127. i: cardinal;
  128. begin
  129. Result:=True;
  130. I:=0;
  131. If (P1)<>(P2) then
  132. While Result and (i<Length) do
  133. begin
  134. Result:=PByte(P1)^=PByte(P2)^;
  135. Inc(I);
  136. Inc(pchar(P1));
  137. Inc(pchar(P2));
  138. end;
  139. end;
  140. { CompareText compares S1 and S2, the result is the based on
  141. substraction of the ascii values of characters in S1 and S2
  142. comparison is case-insensitive
  143. case result
  144. S1 < S2 < 0
  145. S1 > S2 > 0
  146. S1 = S2 = 0 }
  147. function CompareText(const S1, S2: string): integer;
  148. var
  149. i, count, count1, count2: integer; Chr1, Chr2: byte;
  150. begin
  151. result := 0;
  152. Count1 := Length(S1);
  153. Count2 := Length(S2);
  154. if (Count1>Count2) then
  155. Count := Count2
  156. else
  157. Count := Count1;
  158. i := 0;
  159. while (result=0) and (i<count) do
  160. begin
  161. inc (i);
  162. Chr1 := byte(s1[i]);
  163. Chr2 := byte(s2[i]);
  164. if Chr1 in [97..122] then
  165. dec(Chr1,32);
  166. if Chr2 in [97..122] then
  167. dec(Chr2,32);
  168. result := Chr1 - Chr2;
  169. end ;
  170. if (result = 0) then
  171. result:=(count1-count2);
  172. end;
  173. function SameText(const s1,s2:String):Boolean;
  174. begin
  175. Result:=CompareText(S1,S2)=0;
  176. end;
  177. {==============================================================================}
  178. { Ansi string functions }
  179. { these functions rely on the character set loaded by the OS }
  180. {==============================================================================}
  181. function GenericAnsiUpperCase(const s: string): string;
  182. var
  183. len, i: integer;
  184. begin
  185. len := length(s);
  186. SetLength(result, len);
  187. for i := 1 to len do
  188. result[i] := UpperCaseTable[ord(s[i])];
  189. end;
  190. function GenericAnsiLowerCase(const s: string): string;
  191. var
  192. len, i: integer;
  193. begin
  194. len := length(s);
  195. SetLength(result, len);
  196. for i := 1 to len do
  197. result[i] := LowerCaseTable[ord(s[i])];
  198. end;
  199. function GenericAnsiCompareStr(const S1, S2: string): PtrInt;
  200. Var
  201. I,L1,L2 : SizeInt;
  202. begin
  203. Result:=0;
  204. L1:=Length(S1);
  205. L2:=Length(S2);
  206. I:=1;
  207. While (Result=0) and ((I<=L1) and (I<=L2)) do
  208. begin
  209. Result:=Ord(S1[I])-Ord(S2[I]); //!! Must be replaced by ansi characters !!
  210. Inc(I);
  211. end;
  212. If Result=0 Then
  213. Result:=L1-L2;
  214. end;
  215. function GenericAnsiCompareText(const S1, S2: string): PtrInt;
  216. Var
  217. I,L1,L2 : SizeInt;
  218. begin
  219. Result:=0;
  220. L1:=Length(S1);
  221. L2:=Length(S2);
  222. I:=1;
  223. While (Result=0) and ((I<=L1) and (I<=L2)) do
  224. begin
  225. Result:=Ord(LowerCaseTable[Ord(S1[I])])-Ord(LowerCaseTable[Ord(S2[I])]); //!! Must be replaced by ansi characters !!
  226. Inc(I);
  227. end;
  228. If Result=0 Then
  229. Result:=L1-L2;
  230. end;
  231. function AnsiSameText(const s1,s2:String):Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
  232. begin
  233. AnsiSameText:=AnsiCompareText(S1,S2)=0;
  234. end;
  235. function AnsiSameStr(const s1,s2:String):Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
  236. begin
  237. AnsiSameStr:=AnsiCompareStr(S1,S2)=0;
  238. end;
  239. function GenericAnsiStrComp(S1, S2: PChar): PtrInt;
  240. begin
  241. Result:=0;
  242. If S1=Nil then
  243. begin
  244. If S2=Nil Then Exit;
  245. result:=-1;
  246. exit;
  247. end;
  248. If S2=Nil then
  249. begin
  250. Result:=1;
  251. exit;
  252. end;
  253. Repeat
  254. Result:=Ord(S1^)-Ord(S2^); //!! Must be replaced by ansi characters !!
  255. Inc(S1);
  256. Inc(S2);
  257. Until (Result<>0) or (S1^=#0) or (S2^=#0);
  258. if (Result=0) and (S1^<>S2^) then // loop ended because exactly one has #0
  259. if S1^=#0 then // shorter string is smaller
  260. result:=-1
  261. else
  262. result:=1;
  263. end;
  264. function GenericAnsiStrIComp(S1, S2: PChar): PtrInt;
  265. begin
  266. Result:=0;
  267. If S1=Nil then
  268. begin
  269. If S2=Nil Then Exit;
  270. result:=-1;
  271. exit;
  272. end;
  273. If S2=Nil then
  274. begin
  275. Result:=1;
  276. exit;
  277. end;
  278. Repeat
  279. Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !!
  280. Inc(S1);
  281. Inc(S2);
  282. Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0))
  283. end;
  284. function GenericAnsiStrLComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  285. Var I : cardinal;
  286. begin
  287. Result:=0;
  288. If MaxLen=0 then exit;
  289. If S1=Nil then
  290. begin
  291. If S2=Nil Then Exit;
  292. result:=-1;
  293. exit;
  294. end;
  295. If S2=Nil then
  296. begin
  297. Result:=1;
  298. exit;
  299. end;
  300. I:=0;
  301. Repeat
  302. Result:=Ord(S1[0])-Ord(S2[0]); //!! Must be replaced by ansi characters !!
  303. Inc(S1);
  304. Inc(S2);
  305. Inc(I);
  306. Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen)
  307. end;
  308. function GenericAnsiStrLIComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  309. Var I : cardinal;
  310. begin
  311. Result:=0;
  312. If MaxLen=0 then exit;
  313. If S1=Nil then
  314. begin
  315. If S2=Nil Then Exit;
  316. result:=-1;
  317. exit;
  318. end;
  319. If S2=Nil then
  320. begin
  321. Result:=1;
  322. exit;
  323. end;
  324. I:=0;
  325. Repeat
  326. Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !!
  327. Inc(S1);
  328. Inc(S2);
  329. Inc(I);
  330. Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen)
  331. end;
  332. function GenericAnsiStrLower(Str: PChar): PChar;
  333. begin
  334. result := Str;
  335. if Str <> Nil then begin
  336. while Str^ <> #0 do begin
  337. Str^ := LowerCaseTable[byte(Str^)];
  338. Str := Str + 1;
  339. end;
  340. end;
  341. end;
  342. function GenericAnsiStrUpper(Str: PChar): PChar;
  343. begin
  344. result := Str;
  345. if Str <> Nil then begin
  346. while Str^ <> #0 do begin
  347. Str^ := UpperCaseTable[byte(Str^)];
  348. Str := Str + 1;
  349. end ;
  350. end ;
  351. end ;
  352. function AnsiLastChar(const S: string): PChar;
  353. begin
  354. //!! No multibyte yet, so we return the last one.
  355. result:=StrEnd(Pchar(S));
  356. Dec(Result);
  357. end ;
  358. function AnsiStrLastChar(Str: PChar): PChar;
  359. begin
  360. //!! No multibyte yet, so we return the last one.
  361. result:=StrEnd(Str);
  362. Dec(Result);
  363. end ;
  364. function AnsiUpperCase(const s: string): string;{$ifdef SYSUTILSINLINE}inline;{$endif}
  365. begin
  366. result:=widestringmanager.UpperAnsiStringProc(s);
  367. end;
  368. function AnsiLowerCase(const s: string): string;{$ifdef SYSUTILSINLINE}inline;{$endif}
  369. begin
  370. result:=widestringmanager.LowerAnsiStringProc(s);
  371. end;
  372. function AnsiCompareStr(const S1, S2: string): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  373. begin
  374. result:=widestringmanager.CompareStrAnsiStringProc(s1,s2);
  375. end;
  376. function AnsiCompareText(const S1, S2: string): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  377. begin
  378. result:=widestringmanager.CompareTextAnsiStringProc(s1,s2);
  379. end;
  380. function AnsiStrComp(S1, S2: PChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  381. begin
  382. result:=widestringmanager.StrCompAnsiStringProc(s1,s2);
  383. end;
  384. function AnsiStrIComp(S1, S2: PChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  385. begin
  386. result:=widestringmanager.StrICompAnsiStringProc(s1,s2);
  387. end;
  388. function AnsiStrLComp(S1, S2: PChar; MaxLen: cardinal): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  389. begin
  390. result:=widestringmanager.StrLCompAnsiStringProc(s1,s2,maxlen);
  391. end;
  392. function AnsiStrLIComp(S1, S2: PChar; MaxLen: cardinal): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
  393. begin
  394. result:=widestringmanager.StrLICompAnsiStringProc(s1,s2,maxlen);
  395. end;
  396. function AnsiStrLower(Str: PChar): PChar;{$ifdef SYSUTILSINLINE}inline;{$endif}
  397. begin
  398. result:=widestringmanager.StrLowerAnsiStringProc(Str);
  399. end;
  400. function AnsiStrUpper(Str: PChar): PChar;{$ifdef SYSUTILSINLINE}inline;{$endif}
  401. begin
  402. result:=widestringmanager.StrUpperAnsiStringProc(Str);
  403. end;
  404. {==============================================================================}
  405. { End of Ansi functions }
  406. {==============================================================================}
  407. { Trim returns a copy of S with blanks characters on the left and right stripped off }
  408. Const WhiteSpace = [#0..' '];
  409. function Trim(const S: string): string;
  410. var Ofs, Len: integer;
  411. begin
  412. len := Length(S);
  413. while (Len>0) and (S[Len] in WhiteSpace) do
  414. dec(Len);
  415. Ofs := 1;
  416. while (Ofs<=Len) and (S[Ofs] in WhiteSpace) do
  417. Inc(Ofs);
  418. result := Copy(S, Ofs, 1 + Len - Ofs);
  419. end ;
  420. { TrimLeft returns a copy of S with all blank characters on the left stripped off }
  421. function TrimLeft(const S: string): string;
  422. var i,l:integer;
  423. begin
  424. l := length(s);
  425. i := 1;
  426. while (i<=l) and (s[i] in whitespace) do
  427. inc(i);
  428. Result := copy(s, i, l);
  429. end ;
  430. { TrimRight returns a copy of S with all blank characters on the right stripped off }
  431. function TrimRight(const S: string): string;
  432. var l:integer;
  433. begin
  434. l := length(s);
  435. while (l>0) and (s[l] in whitespace) do
  436. dec(l);
  437. result := copy(s,1,l);
  438. end ;
  439. { QuotedStr returns S quoted left and right and every single quote in S
  440. replaced by two quotes }
  441. function QuotedStr(const S: string): string;
  442. begin
  443. result := AnsiQuotedStr(s, '''');
  444. end ;
  445. { AnsiQuotedStr returns S quoted left and right by Quote,
  446. and every single occurance of Quote replaced by two }
  447. function AnsiQuotedStr(const S: string; Quote: char): string;
  448. var i, j, count: integer;
  449. begin
  450. result := '' + Quote;
  451. count := length(s);
  452. i := 0;
  453. j := 0;
  454. while i < count do begin
  455. i := i + 1;
  456. if S[i] = Quote then begin
  457. result := result + copy(S, 1 + j, i - j) + Quote;
  458. j := i;
  459. end ;
  460. end ;
  461. if i <> j then
  462. result := result + copy(S, 1 + j, i - j);
  463. result := result + Quote;
  464. end ;
  465. { AnsiExtractQuotedStr returns a copy of Src with quote characters
  466. deleted to the left and right and double occurances
  467. of Quote replaced by a single Quote }
  468. function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
  469. var
  470. P,Q,R: PChar;
  471. begin
  472. P := Src;
  473. Q := StrEnd(P);
  474. result:='';
  475. if P=Q then exit;
  476. if P^<>quote then exit;
  477. inc(p);
  478. setlength(result,(Q-P)+1);
  479. R:=@Result[1];
  480. while P <> Q do
  481. begin
  482. R^:=P^;
  483. inc(R);
  484. if (P^ = Quote) then
  485. begin
  486. P := P + 1;
  487. if (p^ <> Quote) then
  488. begin
  489. dec(R);
  490. break;
  491. end;
  492. end;
  493. P := P + 1;
  494. end ;
  495. src:=p;
  496. SetLength(result, (R-pchar(@Result[1])));
  497. end ;
  498. { AdjustLineBreaks returns S with all CR characters not followed by LF
  499. replaced with CR/LF }
  500. // under Linux all CR characters or CR/LF combinations should be replaced with LF
  501. function AdjustLineBreaks(const S: string): string;
  502. begin
  503. Result:=AdjustLineBreaks(S,DefaultTextLineBreakStyle);
  504. end;
  505. function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;
  506. var
  507. Source,Dest: PChar;
  508. DestLen: Integer;
  509. I,J,L: Longint;
  510. begin
  511. Source:=Pointer(S);
  512. L:=Length(S);
  513. DestLen:=L;
  514. I:=1;
  515. while (I<=L) do
  516. begin
  517. case S[i] of
  518. #10: if (Style=tlbsCRLF) then
  519. Inc(DestLen);
  520. #13: if (Style=tlbsCRLF) then
  521. if (I<L) and (S[i+1]=#10) then
  522. Inc(I)
  523. else
  524. Inc(DestLen)
  525. else if (I<L) and (S[I+1]=#10) then
  526. Dec(DestLen);
  527. end;
  528. Inc(I);
  529. end;
  530. if (DestLen=L) then
  531. Result:=S
  532. else
  533. begin
  534. SetLength(Result, DestLen);
  535. FillChar(Result[1],DestLen,0);
  536. Dest := Pointer(Result);
  537. J:=0;
  538. I:=0;
  539. While I<L do
  540. case Source[I] of
  541. #10: begin
  542. if Style=tlbsCRLF then
  543. begin
  544. Dest[j]:=#13;
  545. Inc(J);
  546. end;
  547. Dest[J] := #10;
  548. Inc(J);
  549. Inc(I);
  550. end;
  551. #13: begin
  552. if Style=tlbsCRLF then
  553. begin
  554. Dest[j] := #13;
  555. Inc(J);
  556. end;
  557. Dest[j]:=#10;
  558. Inc(J);
  559. Inc(I);
  560. if Source[I]=#10 then
  561. Inc(I);
  562. end;
  563. else
  564. Dest[j]:=Source[i];
  565. Inc(J);
  566. Inc(I);
  567. end;
  568. end;
  569. end;
  570. { IsValidIdent returns true if the first character of Ident is in:
  571. 'A' to 'Z', 'a' to 'z' or '_' and the following characters are
  572. on of: 'A' to 'Z', 'a' to 'z', '0'..'9' or '_' }
  573. function IsValidIdent(const Ident: string): boolean;
  574. var i, len: integer;
  575. begin
  576. result := false;
  577. len := length(Ident);
  578. if len <> 0 then begin
  579. result := Ident[1] in ['A'..'Z', 'a'..'z', '_'];
  580. i := 1;
  581. while (result) and (i < len) do begin
  582. i := i + 1;
  583. result := result and (Ident[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  584. end ;
  585. end ;
  586. end ;
  587. { IntToStr returns a string representing the value of Value }
  588. function IntToStr(Value: integer): string;
  589. begin
  590. System.Str(Value, result);
  591. end ;
  592. function IntToStr(Value: int64): string;
  593. begin
  594. System.Str(Value, result);
  595. end ;
  596. function IntToStr(Value: QWord): string;
  597. begin
  598. System.Str(Value, result);
  599. end ;
  600. { IntToHex returns a string representing the hexadecimal value of Value }
  601. const
  602. HexDigits: array[0..15] of char = '0123456789ABCDEF';
  603. function IntToHex(Value: integer; Digits: integer): string;
  604. var i: integer;
  605. begin
  606. SetLength(result, digits);
  607. for i := 0 to digits - 1 do
  608. begin
  609. result[digits - i] := HexDigits[value and 15];
  610. value := value shr 4;
  611. end ;
  612. while value <> 0 do begin
  613. result := HexDigits[value and 15] + result;
  614. value := value shr 4;
  615. end;
  616. end ;
  617. function IntToHex(Value: int64; Digits: integer): string;
  618. var i: integer;
  619. begin
  620. SetLength(result, digits);
  621. for i := 0 to digits - 1 do
  622. begin
  623. result[digits - i] := HexDigits[value and 15];
  624. value := value shr 4;
  625. end ;
  626. while value <> 0 do begin
  627. result := HexDigits[value and 15] + result;
  628. value := value shr 4;
  629. end;
  630. end ;
  631. function TryStrToInt(const s: string; var i : integer) : boolean;
  632. var Error : word;
  633. begin
  634. Val(s, i, Error);
  635. TryStrToInt:=Error=0
  636. end;
  637. { StrToInt converts the string S to an integer value,
  638. if S does not represent a valid integer value EConvertError is raised }
  639. function StrToInt(const S: string): integer;
  640. var Error: word;
  641. begin
  642. Val(S, result, Error);
  643. if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
  644. end ;
  645. function StrToInt64(const S: string): int64;
  646. var Error: word;
  647. begin
  648. Val(S, result, Error);
  649. if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
  650. end;
  651. function TryStrToInt64(const s: string; var i : int64) : boolean;
  652. var Error : word;
  653. begin
  654. Val(s, i, Error);
  655. TryStrToInt64:=Error=0
  656. end;
  657. function StrToQWord(const s: string): QWord;
  658. var Error: word;
  659. begin
  660. Val(S, result, Error);
  661. if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
  662. end;
  663. function TryStrToQWord(const s: string; var Q: QWord): boolean;
  664. var Error : word;
  665. begin
  666. Val(s, Q, Error);
  667. TryStrToQWord:=Error=0
  668. end;
  669. { StrToIntDef converts the string S to an integer value,
  670. Default is returned in case S does not represent a valid integer value }
  671. function StrToIntDef(const S: string; Default: integer): integer;
  672. var Error: word;
  673. begin
  674. Val(S, result, Error);
  675. if Error <> 0 then result := Default;
  676. end ;
  677. { StrToInt64Def converts the string S to an int64 value,
  678. Default is returned in case S does not represent a valid int64 value }
  679. function StrToInt64Def(const S: string; Default: int64): int64;
  680. var Error: word;
  681. begin
  682. Val(S, result, Error);
  683. if Error <> 0 then result := Default;
  684. end ;
  685. { StrToQWordDef converts the string S to an QWord value,
  686. Default is returned in case S does not represent a valid QWord value }
  687. function StrToQWordDef(const S: string; Default: QWord): QWord;
  688. var Error: word;
  689. begin
  690. Val(S, result, Error);
  691. if Error <> 0 then result := Default;
  692. end;
  693. { LoadStr returns the string resource Ident. }
  694. function LoadStr(Ident: integer): string;
  695. begin
  696. result:='';
  697. end ;
  698. { FmtLoadStr returns the string resource Ident and formats it accordingly }
  699. function FmtLoadStr(Ident: integer; const Args: array of const): string;
  700. begin
  701. result:='';
  702. end;
  703. Const
  704. feInvalidFormat = 1;
  705. feMissingArgument = 2;
  706. feInvalidArgIndex = 3;
  707. {$ifdef fmtdebug}
  708. Procedure Log (Const S: String);
  709. begin
  710. Writeln (S);
  711. end;
  712. {$endif}
  713. Procedure DoFormatError (ErrCode : Longint);
  714. Var
  715. S : String;
  716. begin
  717. //!! must be changed to contain format string...
  718. S:='';
  719. Case ErrCode of
  720. feInvalidFormat : raise EConvertError.Createfmt(SInvalidFormat,[s]);
  721. feMissingArgument : raise EConvertError.Createfmt(SArgumentMissing,[s]);
  722. feInvalidArgIndex : raise EConvertError.Createfmt(SInvalidArgIndex,[s]);
  723. end;
  724. end;
  725. { we've no templates, but with includes we can simulate this :) }
  726. {$macro on}
  727. {$define INFORMAT}
  728. {$define TFormatString:=ansistring}
  729. {$define TFormatChar:=char}
  730. Function Format (Const Fmt : AnsiString; const Args : Array of const; const FormatSettings: TFormatSettings) : AnsiString;
  731. {$i sysformt.inc}
  732. {$undef TFormatString}
  733. {$undef TFormatChar}
  734. {$undef INFORMAT}
  735. {$macro off}
  736. Function Format (Const Fmt : AnsiString; const Args : Array of const) : AnsiString;
  737. begin
  738. Result:=Format(Fmt,Args,DefaultFormatSettings);
  739. end;
  740. Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal; Const Args : Array of const; Const FormatSettings: TFormatSettings) : Cardinal;
  741. Var S,F : String;
  742. begin
  743. Setlength(F,fmtlen);
  744. if fmtlen > 0 then
  745. Move(fmt,F[1],fmtlen);
  746. S:=Format (F,Args,FormatSettings);
  747. If Cardinal(Length(S))<Buflen then
  748. Result:=Length(S)
  749. else
  750. Result:=Buflen;
  751. Move(S[1],Buffer,Result);
  752. end;
  753. Function FormatBuf (Var Buffer; BufLen : Cardinal;
  754. Const Fmt; fmtLen : Cardinal;
  755. Const Args : Array of const) : Cardinal;
  756. begin
  757. Result:=FormatBuf(Buffer,BufLen,Fmt,FmtLen,Args,DefaultFormatSettings);
  758. end;
  759. Procedure FmtStr(Var Res: string; const Fmt : string; Const args: Array of const; Const FormatSettings: TFormatSettings);
  760. begin
  761. Res:=Format(fmt,Args,FormatSettings);
  762. end;
  763. Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const);
  764. begin
  765. FmtStr(Res,Fmt,Args,DefaultFormatSettings);
  766. end;
  767. Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar;
  768. begin
  769. Result:=StrFmt(Buffer,Fmt,Args,DefaultFormatSettings);
  770. end;
  771. Function StrFmt(Buffer,Fmt : PChar; Const Args: Array of const; Const FormatSettings: TFormatSettings): PChar;
  772. begin
  773. Buffer[FormatBuf(Buffer^,Maxint,Fmt^,strlen(fmt),args,FormatSettings)]:=#0;
  774. Result:=Buffer;
  775. end;
  776. Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar;
  777. begin
  778. Result:=StrLFmt(Buffer,MaxLen,Fmt,Args,DefaultFormatSettings);
  779. end;
  780. Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const; Const FormatSettings: TFormatSettings) : Pchar;
  781. begin
  782. Buffer[FormatBuf(Buffer^,MaxLen,Fmt^,strlen(fmt),args,FormatSettings)]:=#0;
  783. Result:=Buffer;
  784. end;
  785. Function StrToFloat(Const S: String): Extended;
  786. begin
  787. Result:=StrToFloat(S,DefaultFormatSettings);
  788. end;
  789. Function StrToFloat(Const S : String; Const FormatSettings: TFormatSettings) : Extended;
  790. Begin
  791. If Not TextToFloat(Pchar(S),Result,FormatSettings) then
  792. Raise EConvertError.createfmt(SInValidFLoat,[S]);
  793. End;
  794. function StrToFloatDef(const S: string; const Default: Extended): Extended;
  795. begin
  796. Result:=StrToFloatDef(S,Default,DefaultFormatSettings);
  797. end;
  798. Function StrToFloatDef(Const S: String; Const Default: Extended; Const FormatSettings: TFormatSettings): Extended;
  799. begin
  800. if not TextToFloat(PChar(S),Result,fvExtended,FormatSettings) then
  801. Result:=Default;
  802. end;
  803. Function TextToFloat(Buffer: PChar; Var Value: Extended; Const FormatSettings: TFormatSettings): Boolean;
  804. Var
  805. E,P : Integer;
  806. S : String;
  807. Begin
  808. S:=StrPas(Buffer);
  809. P:=Pos(FormatSettings.DecimalSeparator,S);
  810. If (P<>0) Then
  811. S[P] := '.';
  812. Val(trim(S),Value,E);
  813. Result:=(E=0);
  814. End;
  815. Function TextToFloat(Buffer: PChar; Var Value: Extended): Boolean;
  816. begin
  817. Result:=TextToFloat(Buffer,Value,DefaultFormatSettings);
  818. end;
  819. Function TextToFloat(Buffer: PChar; Var Value; ValueType: TFloatValue): Boolean;
  820. begin
  821. Result:=TextToFloat(Buffer,Value,ValueType,DefaultFormatSettings);
  822. end;
  823. Function TextToFloat(Buffer: PChar; Var Value; ValueType: TFloatValue; Const FormatSettings: TFormatSettings): Boolean;
  824. Var
  825. E,P : Integer;
  826. S : String;
  827. {$ifndef FPC_HAS_STR_CURRENCY}
  828. TempValue: extended;
  829. {$endif FPC_HAS_STR_CURRENCY}
  830. Begin
  831. S:=StrPas(Buffer);
  832. P:=Pos(FormatSettings.ThousandSeparator,S);
  833. While (P<>0) do
  834. begin
  835. Delete(S,P,1);
  836. P:=Pos(FormatSettings.ThousandSeparator,S);
  837. end;
  838. P:=Pos(FormatSettings.DecimalSeparator,S);
  839. If (P<>0) Then
  840. S[P] := '.';
  841. case ValueType of
  842. fvCurrency:
  843. {$ifdef FPC_HAS_STR_CURRENCY}
  844. Val(S,Currency(Value),E);
  845. {$else FPC_HAS_STR_CURRENCY}
  846. begin
  847. // needed for platforms where Currency = Int64
  848. Val(S,TempValue,E);
  849. Currency(Value) := TempValue;
  850. end;
  851. {$endif FPC_HAS_STR_CURRENCY}
  852. fvExtended:
  853. Val(S,Extended(Value),E);
  854. fvDouble:
  855. Val(S,Double(Value),E);
  856. fvSingle:
  857. Val(S,Single(Value),E);
  858. fvComp:
  859. Val(S,Comp(Value),E);
  860. fvReal:
  861. Val(S,Real(Value),E);
  862. end;
  863. Result:=(E=0);
  864. End;
  865. Function TryStrToFloat(Const S : String; Var Value: Single): Boolean;
  866. begin
  867. Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
  868. end;
  869. Function TryStrToFloat(Const S : String; Var Value: Single; Const FormatSettings: TFormatSettings): Boolean;
  870. Begin
  871. Result := TextToFloat(PChar(S), Value, fvSingle,FormatSettings);
  872. End;
  873. Function TryStrToFloat(Const S : String; Var Value: Double): Boolean;
  874. begin
  875. Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
  876. end;
  877. Function TryStrToFloat(Const S : String; Var Value: Double; Const FormatSettings: TFormatSettings): Boolean;
  878. Begin
  879. Result := TextToFloat(PChar(S), Value, fvDouble,FormatSettings);
  880. End;
  881. {$ifdef FPC_HAS_TYPE_EXTENDED}
  882. Function TryStrToFloat(Const S : String; Var Value: Extended): Boolean;
  883. begin
  884. Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
  885. end;
  886. Function TryStrToFloat(Const S : String; Var Value: Extended; Const FormatSettings: TFormatSettings): Boolean;
  887. Begin
  888. Result := TextToFloat(PChar(S), Value,FormatSettings);
  889. End;
  890. {$endif FPC_HAS_TYPE_EXTENDED}
  891. const
  892. {$ifdef FPC_HAS_TYPE_EXTENDED}
  893. maxdigits = 17;
  894. {$else}
  895. maxdigits = 15;
  896. {$endif}
  897. Function FloatToStrFIntl(const Value; format: TFloatFormat; Precision, Digits: Integer; ValueType: TFloatValue; Const FormatSettings: TFormatSettings): String;
  898. Var
  899. P: Integer;
  900. Negative, TooSmall, TooLarge: Boolean;
  901. DS: Char;
  902. Begin
  903. DS:=FormatSettings.DecimalSeparator;
  904. Case format Of
  905. ffGeneral:
  906. Begin
  907. case ValueType of
  908. fvCurrency:
  909. begin
  910. If (Precision = -1) Or (Precision > 19) Then Precision := 19;
  911. TooSmall:=False;
  912. end;
  913. else
  914. begin
  915. If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits;
  916. TooSmall := (Abs(Extended(Value)) < 0.00001) and (Extended(Value)<>0.0);
  917. end;
  918. end;
  919. If Not TooSmall Then
  920. Begin
  921. case ValueType of
  922. fvDouble:
  923. Str(Double(Extended(Value)):0:precision, Result);
  924. fvSingle:
  925. Str(Single(Extended(Value)):0:precision, Result);
  926. fvCurrency:
  927. {$ifdef FPC_HAS_STR_CURRENCY}
  928. Str(Currency(Value):0:precision, Result);
  929. {$else}
  930. Str(Extended(Currency(Value)):0:precision, Result);
  931. {$endif FPC_HAS_STR_CURRENCY}
  932. else
  933. Str(Extended(Value):0:precision, Result);
  934. end;
  935. P := Pos('.', Result);
  936. if P<>0 then
  937. Result[P] := DS;
  938. TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0);
  939. End;
  940. If TooSmall Or TooLarge Then
  941. begin
  942. Result := FloatToStrFIntl(Value, ffExponent, Precision, Digits, ValueType,FormatSettings);
  943. // Strip unneeded zeroes.
  944. P:=Pos('E',result)-1;
  945. If P<>-1 then
  946. begin
  947. { delete superfluous +? }
  948. if result[p+2]='+' then
  949. system.Delete(Result,P+2,1);
  950. While (P>1) and (Result[P]='0') do
  951. begin
  952. system.Delete(Result,P,1);
  953. Dec(P);
  954. end;
  955. If (P>0) and (Result[P]=DS) Then
  956. begin
  957. system.Delete(Result,P,1);
  958. Dec(P);
  959. end;
  960. end;
  961. end
  962. else if (P<>0) then // we have a decimalseparator
  963. begin
  964. { it seems that in this unit "precision" must mean "number of }
  965. { significant digits" rather than "number of digits after the }
  966. { decimal point" (as it does in the system unit) -> adjust }
  967. { (precision+1 to count the decimal point character) }
  968. if Result[1] = '-' then
  969. Inc(Precision);
  970. if (Length(Result) > Precision + 1) and
  971. (Precision + 1 > P) then
  972. begin
  973. P := Precision + 1;
  974. SetLength(Result,P);
  975. end;
  976. P := Length(Result);
  977. While (P>0) and (Result[P] = '0') Do
  978. Dec(P);
  979. If (P>0) and (Result[P]=DS) Then
  980. Dec(P);
  981. SetLength(Result, P);
  982. end;
  983. End;
  984. ffExponent:
  985. Begin
  986. If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits;
  987. case ValueType of
  988. fvDouble:
  989. Str(Double(Extended(Value)):Precision+7, Result);
  990. fvSingle:
  991. Str(Single(Extended(Value)):Precision+6, Result);
  992. fvCurrency:
  993. {$ifdef FPC_HAS_STR_CURRENCY}
  994. Str(Currency(Value):Precision+6, Result);
  995. {$else}
  996. Str(Extended(Currency(Value)):Precision+8, Result);
  997. {$endif FPC_HAS_STR_CURRENCY}
  998. else
  999. Str(Extended(Value):Precision+8, Result);
  1000. end;
  1001. { Delete leading spaces }
  1002. while Result[1] = ' ' do
  1003. System.Delete(Result, 1, 1);
  1004. if Result[1] = '-' then
  1005. Result[3] := DS
  1006. else
  1007. Result[2] := DS;
  1008. P:=Pos('E',Result);
  1009. if P <> 0 then
  1010. begin
  1011. Inc(P, 2);
  1012. if Digits > 4 then
  1013. Digits:=4;
  1014. Digits:=Length(Result) - P - Digits + 1;
  1015. if Digits < 0 then
  1016. insert(copy('0000',1,-Digits),Result,P)
  1017. else
  1018. while (Digits > 0) and (Result[P] = '0') do
  1019. begin
  1020. System.Delete(Result, P, 1);
  1021. if P > Length(Result) then
  1022. begin
  1023. System.Delete(Result, P - 2, 2);
  1024. break;
  1025. end;
  1026. Dec(Digits);
  1027. end;
  1028. end;
  1029. End;
  1030. ffFixed:
  1031. Begin
  1032. If Digits = -1 Then Digits := 2
  1033. Else If Digits > 18 Then Digits := 18;
  1034. case ValueType of
  1035. fvDouble:
  1036. Str(Double(Extended(Value)):0:Digits, Result);
  1037. fvSingle:
  1038. Str(Single(Extended(Value)):0:Digits, Result);
  1039. fvCurrency:
  1040. {$ifdef FPC_HAS_STR_CURRENCY}
  1041. Str(Currency(Value):0:Digits, Result);
  1042. {$else}
  1043. Str(Extended(Currency(Value)):0:Digits, Result);
  1044. {$endif FPC_HAS_STR_CURRENCY}
  1045. else
  1046. Str(Extended(Value):0:Digits, Result);
  1047. end;
  1048. If Result[1] = ' ' Then
  1049. System.Delete(Result, 1, 1);
  1050. P := Pos('.', Result);
  1051. If P <> 0 Then Result[P] := DS;
  1052. End;
  1053. ffNumber:
  1054. Begin
  1055. If Digits = -1 Then Digits := 2
  1056. Else If Digits > maxdigits Then Digits := maxdigits;
  1057. case ValueType of
  1058. fvDouble:
  1059. Str(Double(Extended(Value)):0:Digits, Result);
  1060. fvSingle:
  1061. Str(Single(Extended(Value)):0:Digits, Result);
  1062. fvCurrency:
  1063. {$ifdef FPC_HAS_STR_CURRENCY}
  1064. Str(Currency(Value):0:Digits, Result);
  1065. {$else}
  1066. Str(Extended(Currency(Value)):0:Digits, Result);
  1067. {$endif FPC_HAS_STR_CURRENCY}
  1068. else
  1069. Str(Extended(Value):0:Digits, Result);
  1070. end;
  1071. If Result[1] = ' ' Then System.Delete(Result, 1, 1);
  1072. P := Pos('.', Result);
  1073. If P <> 0 Then
  1074. Result[P] := DS
  1075. else
  1076. P := Length(Result)+1;
  1077. Dec(P, 3);
  1078. While (P > 1) Do
  1079. Begin
  1080. If Result[P - 1] <> '-' Then Insert(FormatSettings.ThousandSeparator, Result, P);
  1081. Dec(P, 3);
  1082. End;
  1083. End;
  1084. ffCurrency:
  1085. Begin
  1086. If Digits = -1 Then Digits := FormatSettings.CurrencyDecimals
  1087. Else If Digits > 18 Then Digits := 18;
  1088. case ValueType of
  1089. fvDouble:
  1090. Str(Double(Extended(Value)):0:Digits, Result);
  1091. fvSingle:
  1092. Str(Single(Extended(Value)):0:Digits, Result);
  1093. fvCurrency:
  1094. {$ifdef FPC_HAS_STR_CURRENCY}
  1095. Str(Currency(Value):0:Digits, Result);
  1096. {$else}
  1097. Str(Extended(Currency(Value)):0:Digits, Result);
  1098. {$endif FPC_HAS_STR_CURRENCY}
  1099. else
  1100. Str(Extended(Value):0:Digits, Result);
  1101. end;
  1102. Negative:=Result[1] = '-';
  1103. if Negative then
  1104. System.Delete(Result, 1, 1);
  1105. P := Pos('.', Result);
  1106. If P <> 0 Then Result[P] := DS;
  1107. Dec(P, 3);
  1108. While (P > 1) Do
  1109. Begin
  1110. Insert(FormatSettings.ThousandSeparator, Result, P);
  1111. Dec(P, 3);
  1112. End;
  1113. If Not Negative Then
  1114. Begin
  1115. Case FormatSettings.CurrencyFormat Of
  1116. 0: Result := FormatSettings.CurrencyString + Result;
  1117. 1: Result := Result + FormatSettings.CurrencyString;
  1118. 2: Result := FormatSettings.CurrencyString + ' ' + Result;
  1119. 3: Result := Result + ' ' + FormatSettings.CurrencyString;
  1120. End
  1121. End
  1122. Else
  1123. Begin
  1124. Case NegCurrFormat Of
  1125. 0: Result := '(' + FormatSettings.CurrencyString + Result + ')';
  1126. 1: Result := '-' + FormatSettings.CurrencyString + Result;
  1127. 2: Result := FormatSettings.CurrencyString + '-' + Result;
  1128. 3: Result := FormatSettings.CurrencyString + Result + '-';
  1129. 4: Result := '(' + Result + FormatSettings.CurrencyString + ')';
  1130. 5: Result := '-' + Result + FormatSettings.CurrencyString;
  1131. 6: Result := Result + '-' + FormatSettings.CurrencyString;
  1132. 7: Result := Result + FormatSettings.CurrencyString + '-';
  1133. 8: Result := '-' + Result + ' ' + FormatSettings.CurrencyString;
  1134. 9: Result := '-' + FormatSettings.CurrencyString + ' ' + Result;
  1135. 10: Result := FormatSettings.CurrencyString + ' ' + Result + '-';
  1136. End;
  1137. End;
  1138. End;
  1139. End;
  1140. End;
  1141. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1142. Function FloatToStr(Value: Extended; Const FormatSettings: TFormatSettings): String;
  1143. Begin
  1144. Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvExtended,FormatSettings);
  1145. End;
  1146. Function FloatToStr(Value: Extended): String;
  1147. begin
  1148. Result:=FloatToStr(Value,DefaultFormatSettings);
  1149. end;
  1150. {$endif FPC_HAS_TYPE_EXTENDED}
  1151. Function FloatToStr(Value: Currency; Const FormatSettings: TFormatSettings): String;
  1152. Begin
  1153. Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvCurrency,FormatSettings);
  1154. End;
  1155. Function FloatToStr(Value: Currency): String;
  1156. begin
  1157. Result:=FloatToStr(Value,DefaultFormatSettings);
  1158. end;
  1159. Function FloatToStr(Value: Double; Const FormatSettings: TFormatSettings): String;
  1160. var
  1161. e: Extended;
  1162. Begin
  1163. e := Value;
  1164. Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvDouble,FormatSettings);
  1165. End;
  1166. Function FloatToStr(Value: Double): String;
  1167. begin
  1168. Result:=FloatToStr(Value,DefaultFormatSettings);
  1169. end;
  1170. Function FloatToStr(Value: Single; Const FormatSettings: TFormatSettings): String;
  1171. var
  1172. e: Extended;
  1173. Begin
  1174. e := Value;
  1175. Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvSingle,FormatSettings);
  1176. End;
  1177. Function FloatToStr(Value: Single): String;
  1178. begin
  1179. Result:=FloatToStr(Value,DefaultFormatSettings);
  1180. end;
  1181. Function FloatToStr(Value: Comp; Const FormatSettings: TFormatSettings): String;
  1182. var
  1183. e: Extended;
  1184. Begin
  1185. e := Value;
  1186. Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvComp,FormatSettings);
  1187. End;
  1188. Function FloatToStr(Value: Comp): String;
  1189. begin
  1190. Result:=FloatToStr(Value,DefaultFormatSettings);
  1191. end;
  1192. {$ifndef FPC_COMP_IS_INT64}
  1193. Function FloatToStr(Value: Int64): String;
  1194. begin
  1195. Result:=FloatToStr(Value,DefaultFormatSettings);
  1196. end;
  1197. Function FloatToStr(Value: Int64; Const FormatSettings: TFormatSettings): String;
  1198. var
  1199. e: Extended;
  1200. Begin
  1201. e := Comp(Value);
  1202. Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvComp,FormatSettings);
  1203. End;
  1204. {$endif FPC_COMP_IS_INT64}
  1205. Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): Longint;
  1206. Var
  1207. Tmp: String[40];
  1208. Begin
  1209. Tmp := FloatToStrF(Value, format, Precision, Digits,FormatSettings);
  1210. Result := Length(Tmp);
  1211. Move(Tmp[1], Buffer[0], Result);
  1212. End;
  1213. Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint;
  1214. begin
  1215. Result:=FloatToText(Buffer,Value,Format,Precision,Digits,DefaultFormatSettings);
  1216. end;
  1217. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1218. Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1219. begin
  1220. Result := FloatToStrFIntl(value,format,precision,digits,fvExtended,FormatSettings);
  1221. end;
  1222. Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
  1223. begin
  1224. Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
  1225. end;
  1226. {$endif}
  1227. Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1228. begin
  1229. Result := FloatToStrFIntl(value,format,precision,digits,fvCurrency,FormatSettings);
  1230. end;
  1231. Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer): String;
  1232. begin
  1233. Result:=FloatToStrF(Value,format,Precision,Digits,DefaultFormatSettings);
  1234. end;
  1235. Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1236. var
  1237. e: Extended;
  1238. begin
  1239. e := Value;
  1240. result := FloatToStrFIntl(e,format,precision,digits,fvDouble,FormatSettings);
  1241. end;
  1242. Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer): String;
  1243. begin
  1244. Result:= FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
  1245. end;
  1246. Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1247. var
  1248. e: Extended;
  1249. begin
  1250. e:=Value;
  1251. result := FloatToStrFIntl(e,format,precision,digits,fvSingle,FormatSettings);
  1252. end;
  1253. Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer): String;
  1254. begin
  1255. Result:= FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
  1256. end;
  1257. Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1258. var
  1259. e: Extended;
  1260. begin
  1261. e := Value;
  1262. Result := FloatToStrFIntl(e,format,precision,digits,fvComp,FormatSettings);
  1263. end;
  1264. Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer): String;
  1265. begin
  1266. Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
  1267. end;
  1268. {$ifndef FPC_COMP_IS_INT64}
  1269. Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
  1270. var
  1271. e: Extended;
  1272. begin
  1273. e := Comp(Value);
  1274. result := FloatToStrFIntl(e,format,precision,digits,fvComp,FormatSettings);
  1275. end;
  1276. Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer): String;
  1277. begin
  1278. Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
  1279. end;
  1280. {$endif FPC_COMP_IS_INT64}
  1281. Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer; Const FormatSettings: TFormatSettings): string;
  1282. begin
  1283. result:=FloatToStrF(Value,Format,19,Digits,FormatSettings);
  1284. end;
  1285. Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string;
  1286. begin
  1287. Result:=CurrToStrF(Value,Format,Digits,DefaultFormatSettings);
  1288. end;
  1289. Function FloatToDateTime (Const Value : Extended) : TDateTime;
  1290. begin
  1291. If (Value<MinDateTime) or (Value>MaxDateTime) then
  1292. Raise EConvertError.CreateFmt (SInvalidDateTime,[Value]);
  1293. Result:=Value;
  1294. end;
  1295. function TryFloatToCurr(const Value: Extended; var AResult: Currency): Boolean;
  1296. begin
  1297. Result:=(Value>=MinCurrency) and (Value<=MaxCurrency);
  1298. if Result then
  1299. AResult := Value;
  1300. end;
  1301. function FloatToCurr(const Value: Extended): Currency;
  1302. begin
  1303. if not TryFloatToCurr(Value, Result) then
  1304. Raise EConvertError.CreateFmt(SInvalidCurrency, [FloatToStr(Value)]);
  1305. end;
  1306. Function CurrToStr(Value: Currency): string;
  1307. begin
  1308. Result:=FloatToStrF(Value,ffGeneral,-1,0);
  1309. end;
  1310. function AnsiDequotedStr(const S: string; AQuote: Char): string;
  1311. var p : pchar;
  1312. begin
  1313. p:=pchar(s); // work around CONST
  1314. result:=AnsiExtractquotedStr(p,AQuote);
  1315. if result='' Then
  1316. result:=s;
  1317. end;
  1318. function StrToCurr(const S: string): Currency;
  1319. begin
  1320. if not TextToFloat(PChar(S), Result, fvCurrency) then
  1321. Raise EConvertError.createfmt(SInValidFLoat,[S]);
  1322. end;
  1323. Function TryStrToCurr(Const S : String; Var Value: Currency): Boolean;
  1324. Begin
  1325. Result := TextToFloat(PChar(S), Value, fvCurrency);
  1326. End;
  1327. function StrToCurrDef(const S: string; Default : Currency): Currency;
  1328. begin
  1329. if not TextToFloat(PChar(S), Result, fvCurrency) then
  1330. Result:=Default;
  1331. end;
  1332. function StrToBool(const S: string): Boolean;
  1333. begin
  1334. if not(TryStrToBool(S,Result)) then
  1335. Raise EConvertError.CreateFmt(SInvalidBoolean,[S]);
  1336. end;
  1337. function BoolToStr(B: Boolean;UseBoolStrs:Boolean=False): string;
  1338. procedure CheckStrs;
  1339. begin
  1340. If Length(TrueBoolStrs)=0 then
  1341. begin
  1342. SetLength(TrueBoolStrs,1);
  1343. TrueBoolStrs[0]:='True';
  1344. end;
  1345. If Length(FalseBoolStrs)=0 then
  1346. begin
  1347. SetLength(FalseBoolStrs,1);
  1348. FalseBoolStrs[0]:='False';
  1349. end;
  1350. end;
  1351. begin
  1352. if UseBoolStrs Then
  1353. begin
  1354. CheckStrs;
  1355. if B then
  1356. Result:=TrueBoolStrs[0]
  1357. else
  1358. Result:=FalseBoolStrs[0];
  1359. end
  1360. else
  1361. If B then
  1362. Result:='-1'
  1363. else
  1364. Result:='0';
  1365. end;
  1366. function StrToBoolDef(const S: string; Default: Boolean): Boolean;
  1367. begin
  1368. if not(TryStrToBool(S,Result)) then
  1369. Result:=Default;
  1370. end;
  1371. function TryStrToBool(const S: string; out Value: Boolean): Boolean;
  1372. Var
  1373. Temp : String;
  1374. D : Double;
  1375. Code: word;
  1376. begin
  1377. Temp:=upcase(S);
  1378. Val(temp,D,code);
  1379. Result:=true;
  1380. If Code=0 then
  1381. Value:=(D<>0.0)
  1382. else If Temp='TRUE' then
  1383. Value:=true
  1384. else if Temp='FALSE' then
  1385. Value:=false
  1386. else
  1387. Result:=false;
  1388. end;
  1389. Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar): Integer;
  1390. begin
  1391. Result:=FloatToTextFmt(Buffer,Value,Format,DefaultFormatSettings);
  1392. end;
  1393. Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar;FormatSettings : TFormatSettings): Integer;
  1394. Var
  1395. Digits: String[40]; { String Of Digits }
  1396. Exponent: String[8]; { Exponent strin }
  1397. FmtStart, FmtStop: PChar; { Start And End Of relevant part }
  1398. { Of format String }
  1399. ExpFmt, ExpSize: Integer; { Type And Length Of }
  1400. { exponential format chosen }
  1401. Placehold: Array[1..4] Of Integer; { Number Of placeholders In All }
  1402. { four Sections }
  1403. thousand: Boolean; { thousand separators? }
  1404. UnexpectedDigits: Integer; { Number Of unexpected Digits that }
  1405. { have To be inserted before the }
  1406. { First placeholder. }
  1407. DigitExponent: Integer; { Exponent Of First digit In }
  1408. { Digits Array. }
  1409. { Find end of format section starting at P. False, if empty }
  1410. Function GetSectionEnd(Var P: PChar): Boolean;
  1411. Var
  1412. C: Char;
  1413. SQ, DQ: Boolean;
  1414. Begin
  1415. Result := False;
  1416. SQ := False;
  1417. DQ := False;
  1418. C := P[0];
  1419. While (C<>#0) And ((C<>';') Or SQ Or DQ) Do
  1420. Begin
  1421. Result := True;
  1422. Case C Of
  1423. #34: If Not SQ Then DQ := Not DQ;
  1424. #39: If Not DQ Then SQ := Not SQ;
  1425. End;
  1426. Inc(P);
  1427. C := P[0];
  1428. End;
  1429. End;
  1430. { Find start and end of format section to apply. If section doesn't exist,
  1431. use section 1. If section 2 is used, the sign of value is ignored. }
  1432. Procedure GetSectionRange(section: Integer);
  1433. Var
  1434. Sec: Array[1..3] Of PChar;
  1435. SecOk: Array[1..3] Of Boolean;
  1436. Begin
  1437. Sec[1] := format;
  1438. SecOk[1] := GetSectionEnd(Sec[1]);
  1439. If section > 1 Then
  1440. Begin
  1441. Sec[2] := Sec[1];
  1442. If Sec[2][0] <> #0 Then
  1443. Inc(Sec[2]);
  1444. SecOk[2] := GetSectionEnd(Sec[2]);
  1445. If section > 2 Then
  1446. Begin
  1447. Sec[3] := Sec[2];
  1448. If Sec[3][0] <> #0 Then
  1449. Inc(Sec[3]);
  1450. SecOk[3] := GetSectionEnd(Sec[3]);
  1451. End;
  1452. End;
  1453. If Not SecOk[1] Then
  1454. FmtStart := Nil
  1455. Else
  1456. Begin
  1457. If Not SecOk[section] Then
  1458. section := 1
  1459. Else If section = 2 Then
  1460. Value := -Value; { Remove sign }
  1461. If section = 1 Then FmtStart := format Else
  1462. Begin
  1463. FmtStart := Sec[section - 1];
  1464. Inc(FmtStart);
  1465. End;
  1466. FmtStop := Sec[section];
  1467. End;
  1468. End;
  1469. { Find format section ranging from FmtStart to FmtStop. }
  1470. Procedure GetFormatOptions;
  1471. Var
  1472. Fmt: PChar;
  1473. SQ, DQ: Boolean;
  1474. area: Integer;
  1475. Begin
  1476. SQ := False;
  1477. DQ := False;
  1478. Fmt := FmtStart;
  1479. ExpFmt := 0;
  1480. area := 1;
  1481. thousand := False;
  1482. Placehold[1] := 0;
  1483. Placehold[2] := 0;
  1484. Placehold[3] := 0;
  1485. Placehold[4] := 0;
  1486. While Fmt < FmtStop Do
  1487. Begin
  1488. Case Fmt[0] Of
  1489. #34:
  1490. Begin
  1491. If Not SQ Then
  1492. DQ := Not DQ;
  1493. Inc(Fmt);
  1494. End;
  1495. #39:
  1496. Begin
  1497. If Not DQ Then
  1498. SQ := Not SQ;
  1499. Inc(Fmt);
  1500. End;
  1501. Else
  1502. { if not in quotes, then interpret}
  1503. If Not (SQ Or DQ) Then
  1504. Begin
  1505. Case Fmt[0] Of
  1506. '0':
  1507. Begin
  1508. Case area Of
  1509. 1:
  1510. area := 2;
  1511. 4:
  1512. Begin
  1513. area := 3;
  1514. Inc(Placehold[3], Placehold[4]);
  1515. Placehold[4] := 0;
  1516. End;
  1517. End;
  1518. Inc(Placehold[area]);
  1519. Inc(Fmt);
  1520. End;
  1521. '#':
  1522. Begin
  1523. If area=3 Then
  1524. area:=4;
  1525. Inc(Placehold[area]);
  1526. Inc(Fmt);
  1527. End;
  1528. '.':
  1529. Begin
  1530. If area<3 Then
  1531. area:=3;
  1532. Inc(Fmt);
  1533. End;
  1534. ',':
  1535. Begin
  1536. thousand := True;
  1537. Inc(Fmt);
  1538. End;
  1539. 'e', 'E':
  1540. If ExpFmt = 0 Then
  1541. Begin
  1542. If (Fmt[0]='E') Then
  1543. ExpFmt:=1
  1544. Else
  1545. ExpFmt := 3;
  1546. Inc(Fmt);
  1547. If (Fmt<FmtStop) Then
  1548. Begin
  1549. Case Fmt[0] Of
  1550. '+':
  1551. Begin
  1552. End;
  1553. '-':
  1554. Inc(ExpFmt);
  1555. Else
  1556. ExpFmt := 0;
  1557. End;
  1558. If ExpFmt <> 0 Then
  1559. Begin
  1560. Inc(Fmt);
  1561. ExpSize := 0;
  1562. While (Fmt<FmtStop) And
  1563. (ExpSize<4) And
  1564. (Fmt[0] In ['0'..'9']) Do
  1565. Begin
  1566. Inc(ExpSize);
  1567. Inc(Fmt);
  1568. End;
  1569. End;
  1570. End;
  1571. End
  1572. Else
  1573. Inc(Fmt);
  1574. Else { Case }
  1575. Inc(Fmt);
  1576. End; { Case }
  1577. End { Begin }
  1578. Else
  1579. Inc(Fmt);
  1580. End; { Case }
  1581. End; { While .. Begin }
  1582. End;
  1583. Procedure FloatToStr;
  1584. Var
  1585. I, J, Exp, Width, Decimals, DecimalPoint, len: Integer;
  1586. Begin
  1587. If ExpFmt = 0 Then
  1588. Begin
  1589. { Fixpoint }
  1590. Decimals:=Placehold[3]+Placehold[4];
  1591. Width:=Placehold[1]+Placehold[2]+Decimals;
  1592. If (Decimals=0) Then
  1593. Str(Value:Width:0,Digits)
  1594. Else
  1595. Str(Value:Width+1:Decimals,Digits);
  1596. len:=Length(Digits);
  1597. { Find the decimal point }
  1598. If (Decimals=0) Then
  1599. DecimalPoint:=len+1
  1600. Else
  1601. DecimalPoint:=len-Decimals;
  1602. { If value is very small, and no decimal places
  1603. are desired, remove the leading 0. }
  1604. If (Abs(Value) < 1) And (Placehold[2] = 0) Then
  1605. Begin
  1606. If (Placehold[1]=0) Then
  1607. Delete(Digits,DecimalPoint-1,1)
  1608. Else
  1609. Digits[DecimalPoint-1]:=' ';
  1610. End;
  1611. { Convert optional zeroes to spaces. }
  1612. I:=len;
  1613. J:=DecimalPoint+Placehold[3];
  1614. While (I>J) And (Digits[I]='0') Do
  1615. Begin
  1616. Digits[I] := ' ';
  1617. Dec(I);
  1618. End;
  1619. { If integer value and no obligatory decimal
  1620. places, remove decimal point. }
  1621. If (DecimalPoint < len) And (Digits[DecimalPoint + 1] = ' ') Then
  1622. Digits[DecimalPoint] := ' ';
  1623. { Convert spaces left from obligatory decimal point to zeroes. }
  1624. I:=DecimalPoint-Placehold[2];
  1625. While (I<DecimalPoint) And (Digits[I]=' ') Do
  1626. Begin
  1627. Digits[I] := '0';
  1628. Inc(I);
  1629. End;
  1630. Exp := 0;
  1631. End
  1632. Else
  1633. Begin
  1634. { Scientific: exactly <Width> Digits With <Precision> Decimals
  1635. And adjusted Exponent. }
  1636. If Placehold[1]+Placehold[2]=0 Then
  1637. Placehold[1]:=1;
  1638. Decimals := Placehold[3] + Placehold[4];
  1639. Width:=Placehold[1]+Placehold[2]+Decimals;
  1640. Str(Value:Width+8,Digits);
  1641. { Find and cut out exponent. Always the
  1642. last 6 characters in the string.
  1643. -> 0000E+0000 }
  1644. I:=Length(Digits)-5;
  1645. Val(Copy(Digits,I+1,5),Exp,J);
  1646. Exp:=Exp+1-(Placehold[1]+Placehold[2]);
  1647. Delete(Digits, I, 6);
  1648. { Str() always returns at least one digit after the decimal point.
  1649. If we don't want it, we have to remove it. }
  1650. If (Decimals=0) And (Placehold[1]+Placehold[2]<= 1) Then
  1651. Begin
  1652. If (Digits[4]>='5') Then
  1653. Begin
  1654. Inc(Digits[2]);
  1655. If (Digits[2]>'9') Then
  1656. Begin
  1657. Digits[2] := '1';
  1658. Inc(Exp);
  1659. End;
  1660. End;
  1661. Delete(Digits, 3, 2);
  1662. DecimalPoint := Length(Digits) + 1;
  1663. End
  1664. Else
  1665. Begin
  1666. { Move decimal point at the desired position }
  1667. Delete(Digits, 3, 1);
  1668. DecimalPoint:=2+Placehold[1]+Placehold[2];
  1669. If (Decimals<>0) Then
  1670. Insert('.',Digits,DecimalPoint);
  1671. End;
  1672. { Convert optional zeroes to spaces. }
  1673. I := Length(Digits);
  1674. J := DecimalPoint + Placehold[3];
  1675. While (I > J) And (Digits[I] = '0') Do
  1676. Begin
  1677. Digits[I] := ' ';
  1678. Dec(I);
  1679. End;
  1680. { If integer number and no obligatory decimal paces, remove decimal point }
  1681. If (DecimalPoint<Length(Digits)) And
  1682. (Digits[DecimalPoint+1]=' ') Then
  1683. Digits[DecimalPoint]:=' ';
  1684. If (Digits[1]=' ') Then
  1685. Begin
  1686. Delete(Digits, 1, 1);
  1687. Dec(DecimalPoint);
  1688. End;
  1689. { Calculate exponent string }
  1690. Str(Abs(Exp), Exponent);
  1691. While Length(Exponent)<ExpSize Do
  1692. Insert('0',Exponent,1);
  1693. If Exp >= 0 Then
  1694. Begin
  1695. If (ExpFmt In [1,3]) Then
  1696. Insert('+', Exponent, 1);
  1697. End
  1698. Else
  1699. Insert('-',Exponent,1);
  1700. If (ExpFmt<3) Then
  1701. Insert('E',Exponent,1)
  1702. Else
  1703. Insert('e',Exponent,1);
  1704. End;
  1705. DigitExponent:=DecimalPoint-2;
  1706. If (Digits[1]='-') Then
  1707. Dec(DigitExponent);
  1708. UnexpectedDigits:=DecimalPoint-1-(Placehold[1]+Placehold[2]);
  1709. End;
  1710. Function PutResult: LongInt;
  1711. Var
  1712. SQ, DQ: Boolean;
  1713. Fmt, Buf: PChar;
  1714. Dig, N: Integer;
  1715. Begin
  1716. SQ := False;
  1717. DQ := False;
  1718. Fmt := FmtStart;
  1719. Buf := Buffer;
  1720. Dig := 1;
  1721. While (Fmt<FmtStop) Do
  1722. Begin
  1723. //Write(Fmt[0]);
  1724. Case Fmt[0] Of
  1725. #34:
  1726. Begin
  1727. If Not SQ Then
  1728. DQ := Not DQ;
  1729. Inc(Fmt);
  1730. End;
  1731. #39:
  1732. Begin
  1733. If Not DQ Then
  1734. SQ := Not SQ;
  1735. Inc(Fmt);
  1736. End;
  1737. Else
  1738. If Not (SQ Or DQ) Then
  1739. Begin
  1740. Case Fmt[0] Of
  1741. '0', '#', '.':
  1742. Begin
  1743. If (Dig=1) And (UnexpectedDigits>0) Then
  1744. Begin
  1745. { Everything unexpected is written before the first digit }
  1746. For N := 1 To UnexpectedDigits Do
  1747. Begin
  1748. Buf[0] := Digits[N];
  1749. Inc(Buf);
  1750. If thousand And (Digits[N]<>'-') Then
  1751. Begin
  1752. If (DigitExponent Mod 3 = 0) And (DigitExponent>0) Then
  1753. Begin
  1754. Buf[0] := FormatSettings.ThousandSeparator;
  1755. Inc(Buf);
  1756. End;
  1757. Dec(DigitExponent);
  1758. End;
  1759. End;
  1760. Inc(Dig, UnexpectedDigits);
  1761. End;
  1762. If (Digits[Dig]<>' ') Then
  1763. Begin
  1764. If (Digits[Dig]='.') Then
  1765. Buf[0] := FormatSettings.DecimalSeparator
  1766. Else
  1767. Buf[0] := Digits[Dig];
  1768. Inc(Buf);
  1769. If thousand And (DigitExponent Mod 3 = 0) And (DigitExponent > 0) Then
  1770. Begin
  1771. Buf[0] := FormatSettings.ThousandSeparator;
  1772. Inc(Buf);
  1773. End;
  1774. End;
  1775. Inc(Dig);
  1776. Dec(DigitExponent);
  1777. Inc(Fmt);
  1778. End;
  1779. 'e', 'E':
  1780. Begin
  1781. If ExpFmt <> 0 Then
  1782. Begin
  1783. Inc(Fmt);
  1784. If Fmt < FmtStop Then
  1785. Begin
  1786. If Fmt[0] In ['+', '-'] Then
  1787. Begin
  1788. Inc(Fmt, ExpSize);
  1789. For N:=1 To Length(Exponent) Do
  1790. Buf[N-1] := Exponent[N];
  1791. Inc(Buf,Length(Exponent));
  1792. ExpFmt:=0;
  1793. End;
  1794. Inc(Fmt);
  1795. End;
  1796. End
  1797. Else
  1798. Begin
  1799. { No legal exponential format.
  1800. Simply write the 'E' to the result. }
  1801. Buf[0] := Fmt[0];
  1802. Inc(Buf);
  1803. Inc(Fmt);
  1804. End;
  1805. End;
  1806. Else { Case }
  1807. { Usual character }
  1808. If (Fmt[0]<>',') Then
  1809. Begin
  1810. Buf[0] := Fmt[0];
  1811. Inc(Buf);
  1812. End;
  1813. Inc(Fmt);
  1814. End; { Case }
  1815. End
  1816. Else { IF }
  1817. Begin
  1818. { Character inside single or double quotes }
  1819. Buf[0] := Fmt[0];
  1820. Inc(Buf);
  1821. Inc(Fmt);
  1822. End;
  1823. End; { Case }
  1824. End; { While .. Begin }
  1825. Result:=PtrInt(Buf)-PtrInt(Buffer);
  1826. End;
  1827. Begin
  1828. If (Value>0) Then
  1829. GetSectionRange(1)
  1830. Else If (Value<0) Then
  1831. GetSectionRange(2)
  1832. Else
  1833. GetSectionRange(3);
  1834. If FmtStart = Nil Then
  1835. Begin
  1836. Result := FloatToText(Buffer, Value, ffGeneral, 15, 4, FormatSettings);
  1837. End
  1838. Else
  1839. Begin
  1840. GetFormatOptions;
  1841. If (ExpFmt = 0) And (Abs(Value) >= 1E18) Then
  1842. Result := FloatToText(Buffer, Value, ffGeneral, 15, 4, FormatSettings)
  1843. Else
  1844. Begin
  1845. FloatToStr;
  1846. Result := PutResult;
  1847. End;
  1848. End;
  1849. End;
  1850. Procedure FloatToDecimal(Out Result: TFloatRec; const Value; ValueType: TFloatValue; Precision, Decimals : integer);
  1851. var
  1852. Buffer: String[254]; //Though str func returns only 25 chars, this might change in the future
  1853. Error, N, L, Start, C: Integer;
  1854. GotNonZeroBeforeDot, BeforeDot : boolean;
  1855. begin
  1856. case ValueType of
  1857. fvExtended:
  1858. Str(Extended(Value):25, Buffer);
  1859. fvDouble,
  1860. fvReal:
  1861. Str(Double(Value):23, Buffer);
  1862. fvSingle:
  1863. Str(Single(Value):16, Buffer);
  1864. fvCurrency:
  1865. Str(Currency(Value):25, Buffer);
  1866. fvComp:
  1867. Str(Currency(Value):23, Buffer);
  1868. end;
  1869. N := 1;
  1870. L := Byte(Buffer[0]);
  1871. while Buffer[N]=' ' do
  1872. Inc(N);
  1873. Result.Negative := (Buffer[N] = '-');
  1874. if Result.Negative then
  1875. Inc(N);
  1876. Start := N; //Start of digits
  1877. Result.Exponent := 0; BeforeDot := true;
  1878. GotNonZeroBeforeDot := false;
  1879. while (L>=N) and (Buffer[N]<>'E') do
  1880. begin
  1881. if Buffer[N]='.' then
  1882. BeforeDot := false
  1883. else
  1884. begin
  1885. if BeforeDot then
  1886. begin // Currently this is always 1 char
  1887. Inc(Result.Exponent);
  1888. Result.Digits[N-Start] := Buffer[N];
  1889. if Buffer[N] <> '0' then
  1890. GotNonZeroBeforeDot := true;
  1891. end
  1892. else
  1893. Result.Digits[N-Start-1] := Buffer[N]
  1894. end;
  1895. Inc(N);
  1896. end;
  1897. Inc(N); // Pass through 'E'
  1898. if N<=L then
  1899. begin
  1900. Val(Copy(Buffer, N, L-N+1), C, Error); // Get exponent after 'E'
  1901. Inc(Result.Exponent, C);
  1902. end;
  1903. // Calculate number of digits we have from str
  1904. if BeforeDot then
  1905. N := N - Start - 1
  1906. else
  1907. N := N - Start - 2;
  1908. L := SizeOf(Result.Digits);
  1909. if N<L then
  1910. FillChar(Result.Digits[N], L-N, '0'); //Zero remaining space
  1911. if Decimals + Result.Exponent < Precision Then //After this it is the same as in FloatToDecimal
  1912. N := Decimals + Result.Exponent
  1913. Else
  1914. N := Precision;
  1915. if N >= L Then
  1916. N := L-1;
  1917. if N = 0 Then
  1918. begin
  1919. if Result.Digits[0] >= '5' Then
  1920. begin
  1921. Result.Digits[0] := '1';
  1922. Result.Digits[1] := #0;
  1923. Inc(Result.Exponent);
  1924. end
  1925. Else
  1926. Result.Digits[0] := #0;
  1927. end //N=0
  1928. Else if N > 0 Then
  1929. begin
  1930. if Result.Digits[N] >= '5' Then
  1931. begin
  1932. Repeat
  1933. Result.Digits[N] := #0;
  1934. Dec(N);
  1935. Inc(Result.Digits[N]);
  1936. Until (N = 0) Or (Result.Digits[N] < ':');
  1937. If Result.Digits[0] = ':' Then
  1938. begin
  1939. Result.Digits[0] := '1';
  1940. Inc(Result.Exponent);
  1941. end;
  1942. end
  1943. Else
  1944. begin
  1945. Result.Digits[N] := '0';
  1946. While (N > -1) And (Result.Digits[N] = '0') Do
  1947. begin
  1948. Result.Digits[N] := #0;
  1949. Dec(N);
  1950. end;
  1951. end;
  1952. end //N>0
  1953. Else
  1954. Result.Digits[0] := #0;
  1955. if (Result.Digits[0] = #0) and
  1956. not GotNonZeroBeforeDot then
  1957. begin
  1958. Result.Exponent := 0;
  1959. Result.Negative := False;
  1960. end;
  1961. end;
  1962. Procedure FloatToDecimal(Out Result: TFloatRec; Value: Extended; Precision, Decimals : integer);
  1963. begin
  1964. FloatToDecimal(Result,Value,fvExtended,Precision,Decimals);
  1965. end;
  1966. Function FormatFloat(Const Format : String; Value : Extended; Const FormatSettings: TFormatSettings) : String;
  1967. Var
  1968. buf : Array[0..1024] of char;
  1969. Begin
  1970. Buf[FloatToTextFmt(@Buf[0],Value,Pchar(Format),FormatSettings)]:=#0;
  1971. Result:=StrPas(@Buf[0]);
  1972. End;
  1973. Function FormatFloat(Const format: String; Value: Extended): String;
  1974. begin
  1975. Result:=FormatFloat(Format,Value,DefaultFormatSettings);
  1976. end;
  1977. Function FormatCurr(const Format: string; Value: Currency; Const FormatSettings: TFormatSettings): string;
  1978. begin
  1979. Result := FormatFloat(Format, Value,FormatSettings);
  1980. end;
  1981. function FormatCurr(const Format: string; Value: Currency): string;
  1982. begin
  1983. Result:=FormatCurr(Format,Value,DefaultFormatSettings);
  1984. end;
  1985. {==============================================================================}
  1986. { extra functions }
  1987. {==============================================================================}
  1988. { LeftStr returns Count left-most characters from S }
  1989. function LeftStr(const S: string; Count: integer): string;
  1990. begin
  1991. result := Copy(S, 1, Count);
  1992. end ;
  1993. { RightStr returns Count right-most characters from S }
  1994. function RightStr(const S: string; Count: integer): string;
  1995. begin
  1996. If Count>Length(S) then
  1997. Count:=Length(S);
  1998. result := Copy(S, 1 + Length(S) - Count, Count);
  1999. end;
  2000. { BCDToInt converts the BCD value Value to an integer }
  2001. function BCDToInt(Value: integer): integer;
  2002. var i, j: integer;
  2003. begin
  2004. result := 0;
  2005. j := 1;
  2006. for i := 0 to SizeOf(Value) shr 1 - 1 do begin
  2007. result := result + j * (Value and 15);
  2008. j := j * 10;
  2009. Value := Value shr 4;
  2010. end ;
  2011. end ;
  2012. Function LastDelimiter(const Delimiters, S: string): Integer;
  2013. begin
  2014. Result:=Length(S);
  2015. While (Result>0) and (Pos(S[Result],Delimiters)=0) do
  2016. Dec(Result);
  2017. end;
  2018. Function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
  2019. var
  2020. Srch,OldP,RemS: string; // Srch and Oldp can contain uppercase versions of S,OldPattern
  2021. P : Integer;
  2022. begin
  2023. Srch:=S;
  2024. OldP:=OldPattern;
  2025. if rfIgnoreCase in Flags then
  2026. begin
  2027. Srch:=AnsiUpperCase(Srch);
  2028. OldP:=AnsiUpperCase(OldP);
  2029. end;
  2030. RemS:=S;
  2031. Result:='';
  2032. while (Length(Srch)<>0) do
  2033. begin
  2034. P:=AnsiPos(OldP, Srch);
  2035. if P=0 then
  2036. begin
  2037. Result:=Result+RemS;
  2038. Srch:='';
  2039. end
  2040. else
  2041. begin
  2042. Result:=Result+Copy(RemS,1,P-1)+NewPattern;
  2043. P:=P+Length(OldP);
  2044. RemS:=Copy(RemS,P,Length(RemS)-P+1);
  2045. if not (rfReplaceAll in Flags) then
  2046. begin
  2047. Result:=Result+RemS;
  2048. Srch:='';
  2049. end
  2050. else
  2051. Srch:=Copy(Srch,P,Length(Srch)-P+1);
  2052. end;
  2053. end;
  2054. end;
  2055. Function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;
  2056. begin
  2057. Result:=False;
  2058. If (Index>0) and (Index<=Length(S)) then
  2059. Result:=Pos(S[Index],Delimiters)<>0; // Note we don't do MBCS yet
  2060. end;
  2061. Function ByteToCharLen(const S: string; MaxLen: Integer): Integer;
  2062. begin
  2063. Result:=Length(S);
  2064. If Result>MaxLen then
  2065. Result:=MaxLen;
  2066. end;
  2067. Function ByteToCharIndex(const S: string; Index: Integer): Integer;
  2068. begin
  2069. Result:=Index;
  2070. end;
  2071. Function CharToByteLen(const S: string; MaxLen: Integer): Integer;
  2072. begin
  2073. Result:=Length(S);
  2074. If Result>MaxLen then
  2075. Result:=MaxLen;
  2076. end;
  2077. Function CharToByteIndex(const S: string; Index: Integer): Integer;
  2078. begin
  2079. Result:=Index;
  2080. end;
  2081. Function ByteType(const S: string; Index: Integer): TMbcsByteType;
  2082. begin
  2083. Result:=mbSingleByte;
  2084. end;
  2085. Function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType;
  2086. begin
  2087. Result:=mbSingleByte;
  2088. end;
  2089. Function StrCharLength(const Str: PChar): Integer;
  2090. begin
  2091. result:=widestringmanager.CharLengthPCharProc(Str);
  2092. end;
  2093. Function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet;IgnoreCase: Boolean): Boolean;
  2094. Var
  2095. I,L : Integer;
  2096. S,T : String;
  2097. begin
  2098. Result:=False;
  2099. S:=Switch;
  2100. If IgnoreCase then
  2101. S:=UpperCase(S);
  2102. I:=ParamCount;
  2103. While (Not Result) and (I>0) do
  2104. begin
  2105. L:=Length(Paramstr(I));
  2106. If (L>0) and (ParamStr(I)[1] in Chars) then
  2107. begin
  2108. T:=Copy(ParamStr(I),2,L-1);
  2109. If IgnoreCase then
  2110. T:=UpperCase(T);
  2111. Result:=S=T;
  2112. end;
  2113. Dec(i);
  2114. end;
  2115. end;
  2116. Function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean;
  2117. begin
  2118. Result:=FindCmdLineSwitch(Switch,SwitchChars,IgnoreCase);
  2119. end;
  2120. Function FindCmdLineSwitch(const Switch: string): Boolean;
  2121. begin
  2122. Result:=FindCmdLineSwitch(Switch,SwitchChars,False);
  2123. end;
  2124. function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; MaxCol: Integer): string;
  2125. const
  2126. Quotes = ['''', '"'];
  2127. Var
  2128. L : String;
  2129. C,LQ,BC : Char;
  2130. P,BLen,Len : Integer;
  2131. HB,IBC : Boolean;
  2132. begin
  2133. Result:='';
  2134. L:=Line;
  2135. Blen:=Length(BreakStr);
  2136. If (BLen>0) then
  2137. BC:=BreakStr[1]
  2138. else
  2139. BC:=#0;
  2140. Len:=Length(L);
  2141. While (Len>0) do
  2142. begin
  2143. P:=1;
  2144. LQ:=#0;
  2145. HB:=False;
  2146. IBC:=False;
  2147. While ((P<=Len) and ((P<=MaxCol) or not IBC)) and ((LQ<>#0) or Not HB) do
  2148. begin
  2149. C:=L[P];
  2150. If (C=LQ) then
  2151. LQ:=#0
  2152. else If (C in Quotes) then
  2153. LQ:=C;
  2154. If (LQ<>#0) then
  2155. Inc(P)
  2156. else
  2157. begin
  2158. HB:=((C=BC) and (BreakStr=Copy(L,P,BLen)));
  2159. If HB then
  2160. Inc(P,Blen)
  2161. else
  2162. begin
  2163. If (P>MaxCol) then
  2164. IBC:=C in BreakChars;
  2165. Inc(P);
  2166. end;
  2167. end;
  2168. // Writeln('"',C,'" : IBC : ',IBC,' HB : ',HB,' LQ : ',LQ,' P>MaxCol : ',P>MaxCol);
  2169. end;
  2170. Result:=Result+Copy(L,1,P-1);
  2171. If Not HB then
  2172. Result:=Result+BreakStr;
  2173. Delete(L,1,P-1);
  2174. Len:=Length(L);
  2175. end;
  2176. end;
  2177. function WrapText(const Line: string; MaxCol: Integer): string;
  2178. begin
  2179. Result:=WrapText(Line,sLineBreak, [' ', '-', #9], MaxCol);
  2180. end;
  2181. {
  2182. Case Translation Tables
  2183. Can be used in internationalization support.
  2184. Although these tables can be obtained through system calls
  2185. it is better to not use those, since most implementation are not 100%
  2186. WARNING:
  2187. before modifying a translation table make sure that the current codepage
  2188. of the OS corresponds to the one you make changes to
  2189. }
  2190. const
  2191. { upper case translation table for character set 850 }
  2192. CP850UCT: array[128..255] of char =
  2193. (#128,#154,#144,#182,#142,#182,#143,#128,#210,#211,#212,#216,#215,#222,#142,#143,
  2194. #144,#146,#146,#226,#153,#227,#234,#235,'Y',#153,#154,#157,#156,#157,#158,#159,
  2195. #181,#214,#224,#233,#165,#165,#166,#167,#168,#169,#170,#171,#172,#173,#174,#175,
  2196. #176,#177,#178,#179,#180,#181,#182,#183,#184,#185,#186,#187,#188,#189,#190,#191,
  2197. #192,#193,#194,#195,#196,#197,#199,#199,#200,#201,#202,#203,#204,#205,#206,#207,
  2198. #208,#209,#210,#211,#212,#213,#214,#215,#216,#217,#218,#219,#220,#221,#222,#223,
  2199. #224,#225,#226,#227,#229,#229,#230,#237,#232,#233,#234,#235,#237,#237,#238,#239,
  2200. #240,#241,#242,#243,#244,#245,#246,#247,#248,#249,#250,#251,#252,#253,#254,#255);
  2201. { lower case translation table for character set 850 }
  2202. CP850LCT: array[128..255] of char =
  2203. (#135,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#132,#134,
  2204. #130,#145,#145,#147,#148,#149,#150,#151,#152,#148,#129,#155,#156,#155,#158,#159,
  2205. #160,#161,#162,#163,#164,#164,#166,#167,#168,#169,#170,#171,#172,#173,#174,#175,
  2206. #176,#177,#178,#179,#180,#160,#131,#133,#184,#185,#186,#187,#188,#189,#190,#191,
  2207. #192,#193,#194,#195,#196,#197,#198,#198,#200,#201,#202,#203,#204,#205,#206,#207,
  2208. #208,#209,#136,#137,#138,#213,#161,#140,#139,#217,#218,#219,#220,#221,#141,#223,
  2209. #162,#225,#147,#149,#228,#228,#230,#237,#232,#163,#150,#151,#236,#236,#238,#239,
  2210. #240,#241,#242,#243,#244,#245,#246,#247,#248,#249,#250,#251,#252,#253,#254,#255);
  2211. { upper case translation table for character set ISO 8859/1 Latin 1 }
  2212. CPISO88591UCT: array[192..255] of char =
  2213. ( #192, #193, #194, #195, #196, #197, #198, #199,
  2214. #200, #201, #202, #203, #204, #205, #206, #207,
  2215. #208, #209, #210, #211, #212, #213, #214, #215,
  2216. #216, #217, #218, #219, #220, #221, #222, #223,
  2217. #192, #193, #194, #195, #196, #197, #198, #199,
  2218. #200, #201, #202, #203, #204, #205, #206, #207,
  2219. #208, #209, #210, #211, #212, #213, #214, #247,
  2220. #216, #217, #218, #219, #220, #221, #222, #89 );
  2221. { lower case translation table for character set ISO 8859/1 Latin 1 }
  2222. CPISO88591LCT: array[192..255] of char =
  2223. ( #224, #225, #226, #227, #228, #229, #230, #231,
  2224. #232, #233, #234, #235, #236, #237, #238, #239,
  2225. #240, #241, #242, #243, #244, #245, #246, #215,
  2226. #248, #249, #250, #251, #252, #253, #254, #223,
  2227. #224, #225, #226, #227, #228, #229, #230, #231,
  2228. #232, #233, #234, #235, #236, #237, #238, #239,
  2229. #240, #241, #242, #243, #244, #245, #246, #247,
  2230. #248, #249, #250, #251, #252, #253, #254, #255 );
  2231. function sscanf(const s: string; const fmt : string;const Pointers : array of Pointer) : Integer;
  2232. var
  2233. i,j,n,m : SizeInt;
  2234. s1 : string;
  2235. function GetInt(unsigned : boolean=false) : Integer;
  2236. begin
  2237. s1 := '';
  2238. while (Length(s) > n) and (s[n] = ' ') do
  2239. inc(n);
  2240. { read sign }
  2241. if (Length(s)>= n) and (s[n] in ['+', '-']) then
  2242. begin
  2243. { don't accept - when reading unsigned }
  2244. if unsigned and (s[n]='-') then
  2245. begin
  2246. result:=length(s1);
  2247. exit;
  2248. end
  2249. else
  2250. begin
  2251. s1:=s1+s[n];
  2252. inc(n);
  2253. end;
  2254. end;
  2255. { read numbers }
  2256. while (Length(s) >= n) and
  2257. (s[n] in ['0'..'9']) do
  2258. begin
  2259. s1 := s1+s[n];
  2260. inc(n);
  2261. end;
  2262. Result := Length(s1);
  2263. end;
  2264. function GetFloat : Integer;
  2265. begin
  2266. s1 := '';
  2267. while (Length(s) > n) and (s[n] = ' ') do
  2268. inc(n);
  2269. while (Length(s) >= n) and
  2270. (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) do
  2271. begin
  2272. s1 := s1+s[n];
  2273. inc(n);
  2274. end;
  2275. Result := Length(s1);
  2276. end;
  2277. function GetString : Integer;
  2278. begin
  2279. s1 := '';
  2280. while (Length(s) > n) and (s[n] = ' ') do
  2281. inc(n);
  2282. while (Length(s) >= n) and (s[n] <> ' ')do
  2283. begin
  2284. s1 := s1+s[n];
  2285. inc(n);
  2286. end;
  2287. Result := Length(s1);
  2288. end;
  2289. function ScanStr(c : Char) : Boolean;
  2290. begin
  2291. while (Length(s) > n) and (s[n] <> c) do
  2292. inc(n);
  2293. inc(n);
  2294. If (n <= Length(s)) then
  2295. Result := True
  2296. else
  2297. Result := False;
  2298. end;
  2299. function GetFmt : Integer;
  2300. begin
  2301. Result := -1;
  2302. while true do
  2303. begin
  2304. while (Length(fmt) > m) and (fmt[m] = ' ') do
  2305. inc(m);
  2306. if (m >= Length(fmt)) then
  2307. break;
  2308. if (fmt[m] = '%') then
  2309. begin
  2310. inc(m);
  2311. case fmt[m] of
  2312. 'd':
  2313. Result:=vtInteger;
  2314. 'f':
  2315. Result:=vtExtended;
  2316. 's':
  2317. Result:=vtString;
  2318. 'c':
  2319. Result:=vtChar;
  2320. else
  2321. raise EFormatError.CreateFmt(SInvalidFormat,[fmt]);
  2322. end;
  2323. inc(m);
  2324. break;
  2325. end;
  2326. if not(ScanStr(fmt[m])) then
  2327. break;
  2328. inc(m);
  2329. end;
  2330. end;
  2331. begin
  2332. n := 1;
  2333. m := 1;
  2334. Result := 0;
  2335. for i:=0 to High(Pointers) do
  2336. begin
  2337. j := GetFmt;
  2338. case j of
  2339. vtInteger :
  2340. begin
  2341. if GetInt>0 then
  2342. begin
  2343. pLongint(Pointers[i])^:=StrToInt(s1);
  2344. inc(Result);
  2345. end
  2346. else
  2347. break;
  2348. end;
  2349. vtchar :
  2350. begin
  2351. if Length(s)>n then
  2352. begin
  2353. pchar(Pointers[i])^:=s[n];
  2354. inc(n);
  2355. inc(Result);
  2356. end
  2357. else
  2358. break;
  2359. end;
  2360. vtExtended :
  2361. begin
  2362. if GetFloat>0 then
  2363. begin
  2364. pextended(Pointers[i])^:=StrToFloat(s1);
  2365. inc(Result);
  2366. end
  2367. else
  2368. break;
  2369. end;
  2370. vtString :
  2371. begin
  2372. if GetString > 0 then
  2373. begin
  2374. pansistring(Pointers[i])^:=s1;
  2375. inc(Result);
  2376. end
  2377. else
  2378. break;
  2379. end;
  2380. else
  2381. break;
  2382. end;
  2383. end;
  2384. end;