sysstr.inc 73 KB

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