12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810 |
- {
- *********************************************************************
- Copyright (C) 1997, 1998 Gertjan Schouten
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- *********************************************************************
- System Utilities For Free Pascal
- }
- { NewStr creates a new PString and assigns S to it
- if length(s) = 0 NewStr returns Nil }
- function NewStr(const S: string): PString;
- begin
- if (S='') then
- Result:=nil
- else
- begin
- new(result);
- if (Result<>nil) then
- Result^:=s;
- end;
- end;
- { DisposeStr frees the memory occupied by S }
- procedure DisposeStr(S: PString);
- begin
- if S <> Nil then
- begin
- dispose(s);
- S:=nil;
- end;
- end;
- { AssignStr assigns S to P^ }
- procedure AssignStr(var P: PString; const S: string);
- begin
- P^ := s;
- end ;
- { AppendStr appends S to Dest }
- procedure AppendStr(var Dest: String; const S: string);
- begin
- Dest := Dest + S;
- end ;
- { UpperCase returns a copy of S where all lowercase characters ( from a to z )
- have been converted to uppercase }
- Function UpperCase(Const S : String) : String;
- Var
- i : Integer;
- P : PChar;
- begin
- Result := S;
- UniqueString(Result);
- P:=Pchar(Result);
- for i := 1 to Length(Result) do
- begin
- if (P^ in ['a'..'z']) then P^ := char(byte(p^) - 32);
- Inc(P);
- end;
- end;
- { LowerCase returns a copy of S where all uppercase characters ( from A to Z )
- have been converted to lowercase }
- Function Lowercase(Const S : String) : String;
- Var
- i : Integer;
- P : PChar;
- begin
- Result := S;
- UniqueString(Result);
- P:=Pchar(Result);
- for i := 1 to Length(Result) do
- begin
- if (P^ in ['A'..'Z']) then P^ := char(byte(p^) + 32);
- Inc(P);
- end;
- end;
- function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=LowerCase(ansistring(V));
- end;
- { CompareStr compares S1 and S2, the result is the based on
- substraction of the ascii values of the characters in S1 and S2
- case result
- S1 < S2 < 0
- S1 > S2 > 0
- S1 = S2 = 0 }
- function CompareStr(const S1, S2: string): Integer;
- var count, count1, count2: integer;
- begin
- result := 0;
- Count1 := Length(S1);
- Count2 := Length(S2);
- if Count1>Count2 then
- Count:=Count2
- else
- Count:=Count1;
- result := CompareMemRange(Pointer(S1),Pointer(S2), Count);
- if result=0 then
- result:=Count1-Count2;
- end;
- { CompareMemRange returns the result of comparison of Length bytes at P1 and P2
- case result
- P1 < P2 < 0
- P1 > P2 > 0
- P1 = P2 = 0 }
- function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer;
- var
- i: cardinal;
- begin
- i := 0;
- result := 0;
- while (result=0) and (I<length) do
- begin
- result:=byte(P1^)-byte(P2^);
- P1:=pchar(P1)+1; // VP compat.
- P2:=pchar(P2)+1;
- i := i + 1;
- end ;
- end ;
- function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean;
- var
- i: cardinal;
- begin
- Result:=True;
- I:=0;
- If (P1)<>(P2) then
- While Result and (i<Length) do
- begin
- Result:=PByte(P1)^=PByte(P2)^;
- Inc(I);
- Inc(pchar(P1));
- Inc(pchar(P2));
- end;
- end;
- { CompareText compares S1 and S2, the result is the based on
- substraction of the ascii values of characters in S1 and S2
- comparison is case-insensitive
- case result
- S1 < S2 < 0
- S1 > S2 > 0
- S1 = S2 = 0 }
- function CompareText(const S1, S2: string): integer;
- var
- i, count, count1, count2: integer; Chr1, Chr2: byte;
- begin
- result := 0;
- Count1 := Length(S1);
- Count2 := Length(S2);
- if (Count1>Count2) then
- Count := Count2
- else
- Count := Count1;
- i := 0;
- while (result=0) and (i<count) do
- begin
- inc (i);
- Chr1 := byte(s1[i]);
- Chr2 := byte(s2[i]);
- if Chr1 in [97..122] then
- dec(Chr1,32);
- if Chr2 in [97..122] then
- dec(Chr2,32);
- result := Chr1 - Chr2;
- end ;
- if (result = 0) then
- result:=(count1-count2);
- end;
- function SameText(const s1,s2:String):Boolean;
- begin
- Result:=CompareText(S1,S2)=0;
- end;
- {==============================================================================}
- { Ansi string functions }
- { these functions rely on the character set loaded by the OS }
- {==============================================================================}
- function GenericAnsiUpperCase(const s: string): string;
- var
- len, i: integer;
- begin
- len := length(s);
- SetLength(result, len);
- for i := 1 to len do
- result[i] := UpperCaseTable[ord(s[i])];
- end;
- function GenericAnsiLowerCase(const s: string): string;
- var
- len, i: integer;
- begin
- len := length(s);
- SetLength(result, len);
- for i := 1 to len do
- result[i] := LowerCaseTable[ord(s[i])];
- end;
- function GenericAnsiCompareStr(const S1, S2: string): PtrInt;
- Var
- I,L1,L2 : SizeInt;
- begin
- Result:=0;
- L1:=Length(S1);
- L2:=Length(S2);
- I:=1;
- While (Result=0) and ((I<=L1) and (I<=L2)) do
- begin
- Result:=Ord(S1[I])-Ord(S2[I]); //!! Must be replaced by ansi characters !!
- Inc(I);
- end;
- If Result=0 Then
- Result:=L1-L2;
- end;
- function GenericAnsiCompareText(const S1, S2: string): PtrInt;
- Var
- I,L1,L2 : SizeInt;
- begin
- Result:=0;
- L1:=Length(S1);
- L2:=Length(S2);
- I:=1;
- While (Result=0) and ((I<=L1) and (I<=L2)) do
- begin
- Result:=Ord(LowerCaseTable[Ord(S1[I])])-Ord(LowerCaseTable[Ord(S2[I])]); //!! Must be replaced by ansi characters !!
- Inc(I);
- end;
- If Result=0 Then
- Result:=L1-L2;
- end;
- function AnsiSameText(const s1,s2:String):Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- AnsiSameText:=AnsiCompareText(S1,S2)=0;
- end;
- function AnsiSameStr(const s1,s2:String):Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- AnsiSameStr:=AnsiCompareStr(S1,S2)=0;
- end;
- function GenericAnsiStrComp(S1, S2: PChar): PtrInt;
- begin
- Result:=0;
- If S1=Nil then
- begin
- If S2=Nil Then Exit;
- result:=-1;
- exit;
- end;
- If S2=Nil then
- begin
- Result:=1;
- exit;
- end;
- Repeat
- Result:=Ord(S1^)-Ord(S2^); //!! Must be replaced by ansi characters !!
- Inc(S1);
- Inc(S2);
- Until (Result<>0) or (S1^=#0) or (S2^=#0);
- if (Result=0) and (S1^<>S2^) then // loop ended because exactly one has #0
- if S1^=#0 then // shorter string is smaller
- result:=-1
- else
- result:=1;
- end;
- function GenericAnsiStrIComp(S1, S2: PChar): PtrInt;
- begin
- Result:=0;
- If S1=Nil then
- begin
- If S2=Nil Then Exit;
- result:=-1;
- exit;
- end;
- If S2=Nil then
- begin
- Result:=1;
- exit;
- end;
- Repeat
- Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !!
- Inc(S1);
- Inc(S2);
- Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0))
- end;
- function GenericAnsiStrLComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
- Var I : cardinal;
- begin
- Result:=0;
- If MaxLen=0 then exit;
- If S1=Nil then
- begin
- If S2=Nil Then Exit;
- result:=-1;
- exit;
- end;
- If S2=Nil then
- begin
- Result:=1;
- exit;
- end;
- I:=0;
- Repeat
- Result:=Ord(S1[0])-Ord(S2[0]); //!! Must be replaced by ansi characters !!
- Inc(S1);
- Inc(S2);
- Inc(I);
- Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen)
- end;
- function GenericAnsiStrLIComp(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
- Var I : cardinal;
- begin
- Result:=0;
- If MaxLen=0 then exit;
- If S1=Nil then
- begin
- If S2=Nil Then Exit;
- result:=-1;
- exit;
- end;
- If S2=Nil then
- begin
- Result:=1;
- exit;
- end;
- I:=0;
- Repeat
- Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !!
- Inc(S1);
- Inc(S2);
- Inc(I);
- Until (Result<>0) or ((S1[0]=#0) or (S2[0]=#0)) or (I=MaxLen)
- end;
- function GenericAnsiStrLower(Str: PChar): PChar;
- begin
- result := Str;
- if Str <> Nil then begin
- while Str^ <> #0 do begin
- Str^ := LowerCaseTable[byte(Str^)];
- Str := Str + 1;
- end;
- end;
- end;
- function GenericAnsiStrUpper(Str: PChar): PChar;
- begin
- result := Str;
- if Str <> Nil then begin
- while Str^ <> #0 do begin
- Str^ := UpperCaseTable[byte(Str^)];
- Str := Str + 1;
- end ;
- end ;
- end ;
- function AnsiLastChar(const S: string): PChar;
- begin
- //!! No multibyte yet, so we return the last one.
- result:=StrEnd(Pchar(S));
- Dec(Result);
- end ;
- function AnsiStrLastChar(Str: PChar): PChar;
- begin
- //!! No multibyte yet, so we return the last one.
- result:=StrEnd(Str);
- Dec(Result);
- end ;
- function AnsiUpperCase(const s: string): string;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.UpperAnsiStringProc(s);
- end;
- function AnsiLowerCase(const s: string): string;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.LowerAnsiStringProc(s);
- end;
- function AnsiCompareStr(const S1, S2: string): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.CompareStrAnsiStringProc(s1,s2);
- end;
- function AnsiCompareText(const S1, S2: string): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.CompareTextAnsiStringProc(s1,s2);
- end;
- function AnsiStrComp(S1, S2: PChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrCompAnsiStringProc(s1,s2);
- end;
- function AnsiStrIComp(S1, S2: PChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrICompAnsiStringProc(s1,s2);
- end;
- function AnsiStrLComp(S1, S2: PChar; MaxLen: cardinal): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrLCompAnsiStringProc(s1,s2,maxlen);
- end;
- function AnsiStrLIComp(S1, S2: PChar; MaxLen: cardinal): integer;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrLICompAnsiStringProc(s1,s2,maxlen);
- end;
- function AnsiStrLower(Str: PChar): PChar;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrLowerAnsiStringProc(Str);
- end;
- function AnsiStrUpper(Str: PChar): PChar;{$ifdef SYSUTILSINLINE}inline;{$endif}
- begin
- result:=widestringmanager.StrUpperAnsiStringProc(Str);
- end;
- {==============================================================================}
- { End of Ansi functions }
- {==============================================================================}
- { Trim returns a copy of S with blanks characters on the left and right stripped off }
- Const WhiteSpace = [#0..' '];
- function Trim(const S: string): string;
- var Ofs, Len: integer;
- begin
- len := Length(S);
- while (Len>0) and (S[Len] in WhiteSpace) do
- dec(Len);
- Ofs := 1;
- while (Ofs<=Len) and (S[Ofs] in WhiteSpace) do
- Inc(Ofs);
- result := Copy(S, Ofs, 1 + Len - Ofs);
- end ;
- { TrimLeft returns a copy of S with all blank characters on the left stripped off }
- function TrimLeft(const S: string): string;
- var i,l:integer;
- begin
- l := length(s);
- i := 1;
- while (i<=l) and (s[i] in whitespace) do
- inc(i);
- Result := copy(s, i, l);
- end ;
- { TrimRight returns a copy of S with all blank characters on the right stripped off }
- function TrimRight(const S: string): string;
- var l:integer;
- begin
- l := length(s);
- while (l>0) and (s[l] in whitespace) do
- dec(l);
- result := copy(s,1,l);
- end ;
- { QuotedStr returns S quoted left and right and every single quote in S
- replaced by two quotes }
- function QuotedStr(const S: string): string;
- begin
- result := AnsiQuotedStr(s, '''');
- end ;
- { AnsiQuotedStr returns S quoted left and right by Quote,
- and every single occurance of Quote replaced by two }
- function AnsiQuotedStr(const S: string; Quote: char): string;
- var i, j, count: integer;
- begin
- result := '' + Quote;
- count := length(s);
- i := 0;
- j := 0;
- while i < count do begin
- i := i + 1;
- if S[i] = Quote then begin
- result := result + copy(S, 1 + j, i - j) + Quote;
- j := i;
- end ;
- end ;
- if i <> j then
- result := result + copy(S, 1 + j, i - j);
- result := result + Quote;
- end ;
- { AnsiExtractQuotedStr returns a copy of Src with quote characters
- deleted to the left and right and double occurances
- of Quote replaced by a single Quote }
- function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
- var
- P,Q,R: PChar;
- begin
- P := Src;
- Q := StrEnd(P);
- result:='';
- if P=Q then exit;
- if P^<>quote then exit;
- inc(p);
- setlength(result,(Q-P)+1);
- R:=@Result[1];
- while P <> Q do
- begin
- R^:=P^;
- inc(R);
- if (P^ = Quote) then
- begin
- P := P + 1;
- if (p^ <> Quote) then
- begin
- dec(R);
- break;
- end;
- end;
- P := P + 1;
- end ;
- src:=p;
- SetLength(result, (R-pchar(@Result[1])));
- end ;
- { AdjustLineBreaks returns S with all CR characters not followed by LF
- replaced with CR/LF }
- // under Linux all CR characters or CR/LF combinations should be replaced with LF
- function AdjustLineBreaks(const S: string): string;
- begin
- Result:=AdjustLineBreaks(S,DefaultTextLineBreakStyle);
- end;
- function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;
- var
- Source,Dest: PChar;
- DestLen: Integer;
- I,J,L: Longint;
- begin
- Source:=Pointer(S);
- L:=Length(S);
- DestLen:=L;
- I:=1;
- while (I<=L) do
- begin
- case S[i] of
- #10: if (Style=tlbsCRLF) then
- Inc(DestLen);
- #13: if (Style=tlbsCRLF) then
- if (I<L) and (S[i+1]=#10) then
- Inc(I)
- else
- Inc(DestLen)
- else if (I<L) and (S[I+1]=#10) then
- Dec(DestLen);
- end;
- Inc(I);
- end;
- if (DestLen=L) then
- Result:=S
- else
- begin
- SetLength(Result, DestLen);
- FillChar(Result[1],DestLen,0);
- Dest := Pointer(Result);
- J:=0;
- I:=0;
- While I<L do
- case Source[I] of
- #10: begin
- if Style=tlbsCRLF then
- begin
- Dest[j]:=#13;
- Inc(J);
- end;
- Dest[J] := #10;
- Inc(J);
- Inc(I);
- end;
- #13: begin
- if Style=tlbsCRLF then
- begin
- Dest[j] := #13;
- Inc(J);
- end;
- Dest[j]:=#10;
- Inc(J);
- Inc(I);
- if Source[I]=#10 then
- Inc(I);
- end;
- else
- Dest[j]:=Source[i];
- Inc(J);
- Inc(I);
- end;
- end;
- end;
- { IsValidIdent returns true if the first character of Ident is in:
- 'A' to 'Z', 'a' to 'z' or '_' and the following characters are
- on of: 'A' to 'Z', 'a' to 'z', '0'..'9' or '_' }
- function IsValidIdent(const Ident: string): boolean;
- var i, len: integer;
- begin
- result := false;
- len := length(Ident);
- if len <> 0 then begin
- result := Ident[1] in ['A'..'Z', 'a'..'z', '_'];
- i := 1;
- while (result) and (i < len) do begin
- i := i + 1;
- result := result and (Ident[i] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
- end ;
- end ;
- end ;
- { IntToStr returns a string representing the value of Value }
- function IntToStr(Value: integer): string;
- begin
- System.Str(Value, result);
- end ;
- function IntToStr(Value: int64): string;
- begin
- System.Str(Value, result);
- end ;
- function IntToStr(Value: QWord): string;
- begin
- System.Str(Value, result);
- end ;
- { IntToHex returns a string representing the hexadecimal value of Value }
- const
- HexDigits: array[0..15] of char = '0123456789ABCDEF';
- function IntToHex(Value: integer; Digits: integer): string;
- var i: integer;
- begin
- SetLength(result, digits);
- for i := 0 to digits - 1 do
- begin
- result[digits - i] := HexDigits[value and 15];
- value := value shr 4;
- end ;
- while value <> 0 do begin
- result := HexDigits[value and 15] + result;
- value := value shr 4;
- end;
- end ;
- function IntToHex(Value: int64; Digits: integer): string;
- var i: integer;
- begin
- SetLength(result, digits);
- for i := 0 to digits - 1 do
- begin
- result[digits - i] := HexDigits[value and 15];
- value := value shr 4;
- end ;
- while value <> 0 do begin
- result := HexDigits[value and 15] + result;
- value := value shr 4;
- end;
- end ;
- function TryStrToInt(const s: string; var i : integer) : boolean;
- var Error : word;
- begin
- Val(s, i, Error);
- TryStrToInt:=Error=0
- end;
- { StrToInt converts the string S to an integer value,
- if S does not represent a valid integer value EConvertError is raised }
- function StrToInt(const S: string): integer;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
- end ;
- function StrToInt64(const S: string): int64;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
- end;
- function TryStrToInt64(const s: string; var i : int64) : boolean;
- var Error : word;
- begin
- Val(s, i, Error);
- TryStrToInt64:=Error=0
- end;
- function StrToQWord(const s: string): QWord;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then raise EConvertError.createfmt(SInvalidInteger,[S]);
- end;
- function TryStrToQWord(const s: string; var Q: QWord): boolean;
- var Error : word;
- begin
- Val(s, Q, Error);
- TryStrToQWord:=Error=0
- end;
- { StrToIntDef converts the string S to an integer value,
- Default is returned in case S does not represent a valid integer value }
- function StrToIntDef(const S: string; Default: integer): integer;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then result := Default;
- end ;
- { StrToInt64Def converts the string S to an int64 value,
- Default is returned in case S does not represent a valid int64 value }
- function StrToInt64Def(const S: string; Default: int64): int64;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then result := Default;
- end ;
- { StrToQWordDef converts the string S to an QWord value,
- Default is returned in case S does not represent a valid QWord value }
- function StrToQWordDef(const S: string; Default: QWord): QWord;
- var Error: word;
- begin
- Val(S, result, Error);
- if Error <> 0 then result := Default;
- end;
- { LoadStr returns the string resource Ident. }
- function LoadStr(Ident: integer): string;
- begin
- result:='';
- end ;
- { FmtLoadStr returns the string resource Ident and formats it accordingly }
- function FmtLoadStr(Ident: integer; const Args: array of const): string;
- begin
- result:='';
- end;
- Const
- feInvalidFormat = 1;
- feMissingArgument = 2;
- feInvalidArgIndex = 3;
- {$ifdef fmtdebug}
- Procedure Log (Const S: String);
- begin
- Writeln (S);
- end;
- {$endif}
- Procedure DoFormatError (ErrCode : Longint);
- Var
- S : String;
- begin
- //!! must be changed to contain format string...
- S:='';
- Case ErrCode of
- feInvalidFormat : raise EConvertError.Createfmt(SInvalidFormat,[s]);
- feMissingArgument : raise EConvertError.Createfmt(SArgumentMissing,[s]);
- feInvalidArgIndex : raise EConvertError.Createfmt(SInvalidArgIndex,[s]);
- end;
- end;
- { we've no templates, but with includes we can simulate this :) }
- {$macro on}
- {$define INFORMAT}
- {$define TFormatString:=ansistring}
- {$define TFormatChar:=char}
- Function Format (Const Fmt : AnsiString; const Args : Array of const; const FormatSettings: TFormatSettings) : AnsiString;
- {$i sysformt.inc}
- {$undef TFormatString}
- {$undef TFormatChar}
- {$undef INFORMAT}
- {$macro off}
- Function Format (Const Fmt : AnsiString; const Args : Array of const) : AnsiString;
- begin
- Result:=Format(Fmt,Args,DefaultFormatSettings);
- end;
- Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal; Const Args : Array of const; Const FormatSettings: TFormatSettings) : Cardinal;
- Var S,F : String;
- begin
- Setlength(F,fmtlen);
- if fmtlen > 0 then
- Move(fmt,F[1],fmtlen);
- S:=Format (F,Args,FormatSettings);
- If Cardinal(Length(S))<Buflen then
- Result:=Length(S)
- else
- Result:=Buflen;
- Move(S[1],Buffer,Result);
- end;
- Function FormatBuf (Var Buffer; BufLen : Cardinal;
- Const Fmt; fmtLen : Cardinal;
- Const Args : Array of const) : Cardinal;
- begin
- Result:=FormatBuf(Buffer,BufLen,Fmt,FmtLen,Args,DefaultFormatSettings);
- end;
- Procedure FmtStr(Var Res: string; const Fmt : string; Const args: Array of const; Const FormatSettings: TFormatSettings);
- begin
- Res:=Format(fmt,Args,FormatSettings);
- end;
- Procedure FmtStr(Var Res: String; Const Fmt : String; Const args: Array of const);
- begin
- FmtStr(Res,Fmt,Args,DefaultFormatSettings);
- end;
- Function StrFmt(Buffer,Fmt : PChar; Const args: Array of const) : Pchar;
- begin
- Result:=StrFmt(Buffer,Fmt,Args,DefaultFormatSettings);
- end;
- Function StrFmt(Buffer,Fmt : PChar; Const Args: Array of const; Const FormatSettings: TFormatSettings): PChar;
- begin
- Buffer[FormatBuf(Buffer^,Maxint,Fmt^,strlen(fmt),args,FormatSettings)]:=#0;
- Result:=Buffer;
- end;
- Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const) : Pchar;
- begin
- Result:=StrLFmt(Buffer,MaxLen,Fmt,Args,DefaultFormatSettings);
- end;
- Function StrLFmt(Buffer : PCHar; Maxlen : Cardinal;Fmt : PChar; Const args: Array of const; Const FormatSettings: TFormatSettings) : Pchar;
- begin
- Buffer[FormatBuf(Buffer^,MaxLen,Fmt^,strlen(fmt),args,FormatSettings)]:=#0;
- Result:=Buffer;
- end;
- Function StrToFloat(Const S: String): Extended;
- begin
- Result:=StrToFloat(S,DefaultFormatSettings);
- end;
- Function StrToFloat(Const S : String; Const FormatSettings: TFormatSettings) : Extended;
- Begin
- If Not TextToFloat(Pchar(S),Result,FormatSettings) then
- Raise EConvertError.createfmt(SInValidFLoat,[S]);
- End;
- function StrToFloatDef(const S: string; const Default: Extended): Extended;
- begin
- Result:=StrToFloatDef(S,Default,DefaultFormatSettings);
- end;
- Function StrToFloatDef(Const S: String; Const Default: Extended; Const FormatSettings: TFormatSettings): Extended;
- begin
- if not TextToFloat(PChar(S),Result,fvExtended,FormatSettings) then
- Result:=Default;
- end;
- Function TextToFloat(Buffer: PChar; Var Value: Extended; Const FormatSettings: TFormatSettings): Boolean;
- Var
- E,P : Integer;
- S : String;
- Begin
- S:=StrPas(Buffer);
- P:=Pos(FormatSettings.DecimalSeparator,S);
- If (P<>0) Then
- S[P] := '.';
- Val(trim(S),Value,E);
- Result:=(E=0);
- End;
- Function TextToFloat(Buffer: PChar; Var Value: Extended): Boolean;
- begin
- Result:=TextToFloat(Buffer,Value,DefaultFormatSettings);
- end;
- Function TextToFloat(Buffer: PChar; Var Value; ValueType: TFloatValue): Boolean;
- begin
- Result:=TextToFloat(Buffer,Value,ValueType,DefaultFormatSettings);
- end;
- Function TextToFloat(Buffer: PChar; Var Value; ValueType: TFloatValue; Const FormatSettings: TFormatSettings): Boolean;
- Var
- E,P : Integer;
- S : String;
- {$ifndef FPC_HAS_STR_CURRENCY}
- TempValue: extended;
- {$endif FPC_HAS_STR_CURRENCY}
- Begin
- S:=StrPas(Buffer);
- P:=Pos(FormatSettings.ThousandSeparator,S);
- While (P<>0) do
- begin
- Delete(S,P,1);
- P:=Pos(FormatSettings.ThousandSeparator,S);
- end;
- P:=Pos(FormatSettings.DecimalSeparator,S);
- If (P<>0) Then
- S[P] := '.';
- case ValueType of
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Val(S,Currency(Value),E);
- {$else FPC_HAS_STR_CURRENCY}
- begin
- // needed for platforms where Currency = Int64
- Val(S,TempValue,E);
- Currency(Value) := TempValue;
- end;
- {$endif FPC_HAS_STR_CURRENCY}
- fvExtended:
- Val(S,Extended(Value),E);
- fvDouble:
- Val(S,Double(Value),E);
- fvSingle:
- Val(S,Single(Value),E);
- fvComp:
- Val(S,Comp(Value),E);
- fvReal:
- Val(S,Real(Value),E);
- end;
- Result:=(E=0);
- End;
- Function TryStrToFloat(Const S : String; Var Value: Single): Boolean;
- begin
- Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
- end;
- Function TryStrToFloat(Const S : String; Var Value: Single; Const FormatSettings: TFormatSettings): Boolean;
- Begin
- Result := TextToFloat(PChar(S), Value, fvSingle,FormatSettings);
- End;
- Function TryStrToFloat(Const S : String; Var Value: Double): Boolean;
- begin
- Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
- end;
- Function TryStrToFloat(Const S : String; Var Value: Double; Const FormatSettings: TFormatSettings): Boolean;
- Begin
- Result := TextToFloat(PChar(S), Value, fvDouble,FormatSettings);
- End;
- {$ifdef FPC_HAS_TYPE_EXTENDED}
- Function TryStrToFloat(Const S : String; Var Value: Extended): Boolean;
- begin
- Result:=TryStrToFloat(S,Value,DefaultFormatSettings);
- end;
- Function TryStrToFloat(Const S : String; Var Value: Extended; Const FormatSettings: TFormatSettings): Boolean;
- Begin
- Result := TextToFloat(PChar(S), Value,FormatSettings);
- End;
- {$endif FPC_HAS_TYPE_EXTENDED}
- const
- {$ifdef FPC_HAS_TYPE_EXTENDED}
- maxdigits = 17;
- {$else}
- maxdigits = 15;
- {$endif}
- Function FloatToStrFIntl(const Value; format: TFloatFormat; Precision, Digits: Integer; ValueType: TFloatValue; Const FormatSettings: TFormatSettings): String;
- Var
- P: Integer;
- Negative, TooSmall, TooLarge: Boolean;
- DS: Char;
-
- Begin
- DS:=FormatSettings.DecimalSeparator;
- Case format Of
- ffGeneral:
- Begin
- case ValueType of
- fvCurrency:
- begin
- If (Precision = -1) Or (Precision > 19) Then Precision := 19;
- TooSmall:=False;
- end;
- else
- begin
- If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits;
- TooSmall := (Abs(Extended(Value)) < 0.00001) and (Extended(Value)<>0.0);
- end;
- end;
- If Not TooSmall Then
- Begin
- case ValueType of
- fvDouble:
- Str(Double(Extended(Value)):0:precision, Result);
- fvSingle:
- Str(Single(Extended(Value)):0:precision, Result);
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Str(Currency(Value):0:precision, Result);
- {$else}
- Str(Extended(Currency(Value)):0:precision, Result);
- {$endif FPC_HAS_STR_CURRENCY}
- else
- Str(Extended(Value):0:precision, Result);
- end;
- P := Pos('.', Result);
- if P<>0 then
- Result[P] := DS;
- TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0);
- End;
- If TooSmall Or TooLarge Then
- begin
- Result := FloatToStrFIntl(Value, ffExponent, Precision, Digits, ValueType,FormatSettings);
- // Strip unneeded zeroes.
- P:=Pos('E',result)-1;
- If P<>-1 then
- begin
- { delete superfluous +? }
- if result[p+2]='+' then
- system.Delete(Result,P+2,1);
- While (P>1) and (Result[P]='0') do
- begin
- system.Delete(Result,P,1);
- Dec(P);
- end;
- If (P>0) and (Result[P]=DS) Then
- begin
- system.Delete(Result,P,1);
- Dec(P);
- end;
- end;
- end
- else if (P<>0) then // we have a decimalseparator
- begin
- { it seems that in this unit "precision" must mean "number of }
- { significant digits" rather than "number of digits after the }
- { decimal point" (as it does in the system unit) -> adjust }
- { (precision+1 to count the decimal point character) }
- if Result[1] = '-' then
- Inc(Precision);
- if (Length(Result) > Precision + 1) and
- (Precision + 1 > P) then
- begin
- P := Precision + 1;
- SetLength(Result,P);
- end;
- P := Length(Result);
- While (P>0) and (Result[P] = '0') Do
- Dec(P);
- If (P>0) and (Result[P]=DS) Then
- Dec(P);
- SetLength(Result, P);
- end;
- End;
- ffExponent:
- Begin
- If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits;
- case ValueType of
- fvDouble:
- Str(Double(Extended(Value)):Precision+7, Result);
- fvSingle:
- Str(Single(Extended(Value)):Precision+6, Result);
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Str(Currency(Value):Precision+6, Result);
- {$else}
- Str(Extended(Currency(Value)):Precision+8, Result);
- {$endif FPC_HAS_STR_CURRENCY}
- else
- Str(Extended(Value):Precision+8, Result);
- end;
- { Delete leading spaces }
- while Result[1] = ' ' do
- System.Delete(Result, 1, 1);
- if Result[1] = '-' then
- Result[3] := DS
- else
- Result[2] := DS;
- P:=Pos('E',Result);
- if P <> 0 then
- begin
- Inc(P, 2);
- if Digits > 4 then
- Digits:=4;
- Digits:=Length(Result) - P - Digits + 1;
- if Digits < 0 then
- insert(copy('0000',1,-Digits),Result,P)
- else
- while (Digits > 0) and (Result[P] = '0') do
- begin
- System.Delete(Result, P, 1);
- if P > Length(Result) then
- begin
- System.Delete(Result, P - 2, 2);
- break;
- end;
- Dec(Digits);
- end;
- end;
- End;
- ffFixed:
- Begin
- If Digits = -1 Then Digits := 2
- Else If Digits > 18 Then Digits := 18;
- case ValueType of
- fvDouble:
- Str(Double(Extended(Value)):0:Digits, Result);
- fvSingle:
- Str(Single(Extended(Value)):0:Digits, Result);
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Str(Currency(Value):0:Digits, Result);
- {$else}
- Str(Extended(Currency(Value)):0:Digits, Result);
- {$endif FPC_HAS_STR_CURRENCY}
- else
- Str(Extended(Value):0:Digits, Result);
- end;
- If Result[1] = ' ' Then
- System.Delete(Result, 1, 1);
- P := Pos('.', Result);
- If P <> 0 Then Result[P] := DS;
- End;
- ffNumber:
- Begin
- If Digits = -1 Then Digits := 2
- Else If Digits > maxdigits Then Digits := maxdigits;
- case ValueType of
- fvDouble:
- Str(Double(Extended(Value)):0:Digits, Result);
- fvSingle:
- Str(Single(Extended(Value)):0:Digits, Result);
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Str(Currency(Value):0:Digits, Result);
- {$else}
- Str(Extended(Currency(Value)):0:Digits, Result);
- {$endif FPC_HAS_STR_CURRENCY}
- else
- Str(Extended(Value):0:Digits, Result);
- end;
- If Result[1] = ' ' Then System.Delete(Result, 1, 1);
- P := Pos('.', Result);
- If P <> 0 Then
- Result[P] := DS
- else
- P := Length(Result)+1;
- Dec(P, 3);
- While (P > 1) Do
- Begin
- If Result[P - 1] <> '-' Then Insert(FormatSettings.ThousandSeparator, Result, P);
- Dec(P, 3);
- End;
- End;
- ffCurrency:
- Begin
- If Digits = -1 Then Digits := FormatSettings.CurrencyDecimals
- Else If Digits > 18 Then Digits := 18;
- case ValueType of
- fvDouble:
- Str(Double(Extended(Value)):0:Digits, Result);
- fvSingle:
- Str(Single(Extended(Value)):0:Digits, Result);
- fvCurrency:
- {$ifdef FPC_HAS_STR_CURRENCY}
- Str(Currency(Value):0:Digits, Result);
- {$else}
- Str(Extended(Currency(Value)):0:Digits, Result);
- {$endif FPC_HAS_STR_CURRENCY}
- else
- Str(Extended(Value):0:Digits, Result);
- end;
- Negative:=Result[1] = '-';
- if Negative then
- System.Delete(Result, 1, 1);
- P := Pos('.', Result);
- If P <> 0 Then Result[P] := DS;
- Dec(P, 3);
- While (P > 1) Do
- Begin
- Insert(FormatSettings.ThousandSeparator, Result, P);
- Dec(P, 3);
- End;
- If Not Negative Then
- Begin
- Case FormatSettings.CurrencyFormat Of
- 0: Result := FormatSettings.CurrencyString + Result;
- 1: Result := Result + FormatSettings.CurrencyString;
- 2: Result := FormatSettings.CurrencyString + ' ' + Result;
- 3: Result := Result + ' ' + FormatSettings.CurrencyString;
- End
- End
- Else
- Begin
- Case NegCurrFormat Of
- 0: Result := '(' + FormatSettings.CurrencyString + Result + ')';
- 1: Result := '-' + FormatSettings.CurrencyString + Result;
- 2: Result := FormatSettings.CurrencyString + '-' + Result;
- 3: Result := FormatSettings.CurrencyString + Result + '-';
- 4: Result := '(' + Result + FormatSettings.CurrencyString + ')';
- 5: Result := '-' + Result + FormatSettings.CurrencyString;
- 6: Result := Result + '-' + FormatSettings.CurrencyString;
- 7: Result := Result + FormatSettings.CurrencyString + '-';
- 8: Result := '-' + Result + ' ' + FormatSettings.CurrencyString;
- 9: Result := '-' + FormatSettings.CurrencyString + ' ' + Result;
- 10: Result := FormatSettings.CurrencyString + ' ' + Result + '-';
- End;
- End;
- End;
- End;
- End;
- {$ifdef FPC_HAS_TYPE_EXTENDED}
- Function FloatToStr(Value: Extended; Const FormatSettings: TFormatSettings): String;
- Begin
- Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvExtended,FormatSettings);
- End;
- Function FloatToStr(Value: Extended): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- {$endif FPC_HAS_TYPE_EXTENDED}
- Function FloatToStr(Value: Currency; Const FormatSettings: TFormatSettings): String;
- Begin
- Result := FloatToStrFIntl(Value, ffGeneral, 15, 0, fvCurrency,FormatSettings);
- End;
- Function FloatToStr(Value: Currency): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- Function FloatToStr(Value: Double; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- Begin
- e := Value;
- Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvDouble,FormatSettings);
- End;
- Function FloatToStr(Value: Double): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- Function FloatToStr(Value: Single; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- Begin
- e := Value;
- Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvSingle,FormatSettings);
- End;
- Function FloatToStr(Value: Single): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- Function FloatToStr(Value: Comp; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- Begin
- e := Value;
- Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvComp,FormatSettings);
- End;
- Function FloatToStr(Value: Comp): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- {$ifndef FPC_COMP_IS_INT64}
- Function FloatToStr(Value: Int64): String;
- begin
- Result:=FloatToStr(Value,DefaultFormatSettings);
- end;
- Function FloatToStr(Value: Int64; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- Begin
- e := Comp(Value);
- Result := FloatToStrFIntl(e, ffGeneral, 15, 0, fvComp,FormatSettings);
- End;
- {$endif FPC_COMP_IS_INT64}
- Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): Longint;
- Var
- Tmp: String[40];
- Begin
- Tmp := FloatToStrF(Value, format, Precision, Digits,FormatSettings);
- Result := Length(Tmp);
- Move(Tmp[1], Buffer[0], Result);
- End;
- Function FloatToText(Buffer: PChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint;
- begin
- Result:=FloatToText(Buffer,Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- {$ifdef FPC_HAS_TYPE_EXTENDED}
- Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- begin
- Result := FloatToStrFIntl(value,format,precision,digits,fvExtended,FormatSettings);
- end;
- Function FloatToStrF(Value: Extended; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- {$endif}
- Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- begin
- Result := FloatToStrFIntl(value,format,precision,digits,fvCurrency,FormatSettings);
- end;
- Function FloatToStrF(Value: Currency; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:=FloatToStrF(Value,format,Precision,Digits,DefaultFormatSettings);
- end;
- Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- begin
- e := Value;
- result := FloatToStrFIntl(e,format,precision,digits,fvDouble,FormatSettings);
- end;
- Function FloatToStrF(Value: Double; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:= FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- begin
- e:=Value;
- result := FloatToStrFIntl(e,format,precision,digits,fvSingle,FormatSettings);
- end;
- Function FloatToStrF(Value: Single; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:= FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- begin
- e := Value;
- Result := FloatToStrFIntl(e,format,precision,digits,fvComp,FormatSettings);
- end;
- Function FloatToStrF(Value: Comp; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- {$ifndef FPC_COMP_IS_INT64}
- Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): String;
- var
- e: Extended;
- begin
- e := Comp(Value);
- result := FloatToStrFIntl(e,format,precision,digits,fvComp,FormatSettings);
- end;
- Function FloatToStrF(Value: Int64; format: TFloatFormat; Precision, Digits: Integer): String;
- begin
- Result:=FloatToStrF(Value,Format,Precision,Digits,DefaultFormatSettings);
- end;
- {$endif FPC_COMP_IS_INT64}
- Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer; Const FormatSettings: TFormatSettings): string;
- begin
- result:=FloatToStrF(Value,Format,19,Digits,FormatSettings);
- end;
- Function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string;
- begin
- Result:=CurrToStrF(Value,Format,Digits,DefaultFormatSettings);
- end;
- Function FloatToDateTime (Const Value : Extended) : TDateTime;
- begin
- If (Value<MinDateTime) or (Value>MaxDateTime) then
- Raise EConvertError.CreateFmt (SInvalidDateTime,[Value]);
- Result:=Value;
- end;
- function TryFloatToCurr(const Value: Extended; var AResult: Currency): Boolean;
- begin
- Result:=(Value>=MinCurrency) and (Value<=MaxCurrency);
- if Result then
- AResult := Value;
- end;
- function FloatToCurr(const Value: Extended): Currency;
- begin
- if not TryFloatToCurr(Value, Result) then
- Raise EConvertError.CreateFmt(SInvalidCurrency, [FloatToStr(Value)]);
- end;
- Function CurrToStr(Value: Currency): string;
- begin
- Result:=FloatToStrF(Value,ffGeneral,-1,0);
- end;
- function AnsiDequotedStr(const S: string; AQuote: Char): string;
- var p : pchar;
- begin
- p:=pchar(s); // work around CONST
- result:=AnsiExtractquotedStr(p,AQuote);
- if result='' Then
- result:=s;
- end;
- function StrToCurr(const S: string): Currency;
- begin
- if not TextToFloat(PChar(S), Result, fvCurrency) then
- Raise EConvertError.createfmt(SInValidFLoat,[S]);
- end;
- Function TryStrToCurr(Const S : String; Var Value: Currency): Boolean;
- Begin
- Result := TextToFloat(PChar(S), Value, fvCurrency);
- End;
- function StrToCurrDef(const S: string; Default : Currency): Currency;
- begin
- if not TextToFloat(PChar(S), Result, fvCurrency) then
- Result:=Default;
- end;
- function StrToBool(const S: string): Boolean;
- begin
- if not(TryStrToBool(S,Result)) then
- Raise EConvertError.CreateFmt(SInvalidBoolean,[S]);
- end;
- function BoolToStr(B: Boolean;UseBoolStrs:Boolean=False): string;
- procedure CheckStrs;
- begin
- If Length(TrueBoolStrs)=0 then
- begin
- SetLength(TrueBoolStrs,1);
- TrueBoolStrs[0]:='True';
- end;
- If Length(FalseBoolStrs)=0 then
- begin
- SetLength(FalseBoolStrs,1);
- FalseBoolStrs[0]:='False';
- end;
- end;
- begin
- if UseBoolStrs Then
- begin
- CheckStrs;
- if B then
- Result:=TrueBoolStrs[0]
- else
- Result:=FalseBoolStrs[0];
- end
- else
- If B then
- Result:='-1'
- else
- Result:='0';
- end;
- function StrToBoolDef(const S: string; Default: Boolean): Boolean;
- begin
- if not(TryStrToBool(S,Result)) then
- Result:=Default;
- end;
-
- function TryStrToBool(const S: string; out Value: Boolean): Boolean;
- Var
- Temp : String;
- D : Double;
- Code: word;
- begin
- Temp:=upcase(S);
- Val(temp,D,code);
- Result:=true;
- If Code=0 then
- Value:=(D<>0.0)
- else If Temp='TRUE' then
- Value:=true
- else if Temp='FALSE' then
- Value:=false
- else
- Result:=false;
- end;
- Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar): Integer;
- begin
- Result:=FloatToTextFmt(Buffer,Value,Format,DefaultFormatSettings);
- end;
- Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar;FormatSettings : TFormatSettings): Integer;
- Var
- Digits: String[40]; { String Of Digits }
- Exponent: String[8]; { Exponent strin }
- FmtStart, FmtStop: PChar; { Start And End Of relevant part }
- { Of format String }
- ExpFmt, ExpSize: Integer; { Type And Length Of }
- { exponential format chosen }
- Placehold: Array[1..4] Of Integer; { Number Of placeholders In All }
- { four Sections }
- thousand: Boolean; { thousand separators? }
- UnexpectedDigits: Integer; { Number Of unexpected Digits that }
- { have To be inserted before the }
- { First placeholder. }
- DigitExponent: Integer; { Exponent Of First digit In }
- { Digits Array. }
- { Find end of format section starting at P. False, if empty }
- Function GetSectionEnd(Var P: PChar): Boolean;
- Var
- C: Char;
- SQ, DQ: Boolean;
- Begin
- Result := False;
- SQ := False;
- DQ := False;
- C := P[0];
- While (C<>#0) And ((C<>';') Or SQ Or DQ) Do
- Begin
- Result := True;
- Case C Of
- #34: If Not SQ Then DQ := Not DQ;
- #39: If Not DQ Then SQ := Not SQ;
- End;
- Inc(P);
- C := P[0];
- End;
- End;
- { Find start and end of format section to apply. If section doesn't exist,
- use section 1. If section 2 is used, the sign of value is ignored. }
- Procedure GetSectionRange(section: Integer);
- Var
- Sec: Array[1..3] Of PChar;
- SecOk: Array[1..3] Of Boolean;
- Begin
- Sec[1] := format;
- SecOk[1] := GetSectionEnd(Sec[1]);
- If section > 1 Then
- Begin
- Sec[2] := Sec[1];
- If Sec[2][0] <> #0 Then
- Inc(Sec[2]);
- SecOk[2] := GetSectionEnd(Sec[2]);
- If section > 2 Then
- Begin
- Sec[3] := Sec[2];
- If Sec[3][0] <> #0 Then
- Inc(Sec[3]);
- SecOk[3] := GetSectionEnd(Sec[3]);
- End;
- End;
- If Not SecOk[1] Then
- FmtStart := Nil
- Else
- Begin
- If Not SecOk[section] Then
- section := 1
- Else If section = 2 Then
- Value := -Value; { Remove sign }
- If section = 1 Then FmtStart := format Else
- Begin
- FmtStart := Sec[section - 1];
- Inc(FmtStart);
- End;
- FmtStop := Sec[section];
- End;
- End;
- { Find format section ranging from FmtStart to FmtStop. }
- Procedure GetFormatOptions;
- Var
- Fmt: PChar;
- SQ, DQ: Boolean;
- area: Integer;
- Begin
- SQ := False;
- DQ := False;
- Fmt := FmtStart;
- ExpFmt := 0;
- area := 1;
- thousand := False;
- Placehold[1] := 0;
- Placehold[2] := 0;
- Placehold[3] := 0;
- Placehold[4] := 0;
- While Fmt < FmtStop Do
- Begin
- Case Fmt[0] Of
- #34:
- Begin
- If Not SQ Then
- DQ := Not DQ;
- Inc(Fmt);
- End;
- #39:
- Begin
- If Not DQ Then
- SQ := Not SQ;
- Inc(Fmt);
- End;
- Else
- { if not in quotes, then interpret}
- If Not (SQ Or DQ) Then
- Begin
- Case Fmt[0] Of
- '0':
- Begin
- Case area Of
- 1:
- area := 2;
- 4:
- Begin
- area := 3;
- Inc(Placehold[3], Placehold[4]);
- Placehold[4] := 0;
- End;
- End;
- Inc(Placehold[area]);
- Inc(Fmt);
- End;
- '#':
- Begin
- If area=3 Then
- area:=4;
- Inc(Placehold[area]);
- Inc(Fmt);
- End;
- '.':
- Begin
- If area<3 Then
- area:=3;
- Inc(Fmt);
- End;
- ',':
- Begin
- thousand := True;
- Inc(Fmt);
- End;
- 'e', 'E':
- If ExpFmt = 0 Then
- Begin
- If (Fmt[0]='E') Then
- ExpFmt:=1
- Else
- ExpFmt := 3;
- Inc(Fmt);
- If (Fmt<FmtStop) Then
- Begin
- Case Fmt[0] Of
- '+':
- Begin
- End;
- '-':
- Inc(ExpFmt);
- Else
- ExpFmt := 0;
- End;
- If ExpFmt <> 0 Then
- Begin
- Inc(Fmt);
- ExpSize := 0;
- While (Fmt<FmtStop) And
- (ExpSize<4) And
- (Fmt[0] In ['0'..'9']) Do
- Begin
- Inc(ExpSize);
- Inc(Fmt);
- End;
- End;
- End;
- End
- Else
- Inc(Fmt);
- Else { Case }
- Inc(Fmt);
- End; { Case }
- End { Begin }
- Else
- Inc(Fmt);
- End; { Case }
- End; { While .. Begin }
- End;
- Procedure FloatToStr;
- Var
- I, J, Exp, Width, Decimals, DecimalPoint, len: Integer;
- Begin
- If ExpFmt = 0 Then
- Begin
- { Fixpoint }
- Decimals:=Placehold[3]+Placehold[4];
- Width:=Placehold[1]+Placehold[2]+Decimals;
- If (Decimals=0) Then
- Str(Value:Width:0,Digits)
- Else
- Str(Value:Width+1:Decimals,Digits);
- len:=Length(Digits);
- { Find the decimal point }
- If (Decimals=0) Then
- DecimalPoint:=len+1
- Else
- DecimalPoint:=len-Decimals;
- { If value is very small, and no decimal places
- are desired, remove the leading 0. }
- If (Abs(Value) < 1) And (Placehold[2] = 0) Then
- Begin
- If (Placehold[1]=0) Then
- Delete(Digits,DecimalPoint-1,1)
- Else
- Digits[DecimalPoint-1]:=' ';
- End;
- { Convert optional zeroes to spaces. }
- I:=len;
- J:=DecimalPoint+Placehold[3];
- While (I>J) And (Digits[I]='0') Do
- Begin
- Digits[I] := ' ';
- Dec(I);
- End;
- { If integer value and no obligatory decimal
- places, remove decimal point. }
- If (DecimalPoint < len) And (Digits[DecimalPoint + 1] = ' ') Then
- Digits[DecimalPoint] := ' ';
- { Convert spaces left from obligatory decimal point to zeroes. }
- I:=DecimalPoint-Placehold[2];
- While (I<DecimalPoint) And (Digits[I]=' ') Do
- Begin
- Digits[I] := '0';
- Inc(I);
- End;
- Exp := 0;
- End
- Else
- Begin
- { Scientific: exactly <Width> Digits With <Precision> Decimals
- And adjusted Exponent. }
- If Placehold[1]+Placehold[2]=0 Then
- Placehold[1]:=1;
- Decimals := Placehold[3] + Placehold[4];
- Width:=Placehold[1]+Placehold[2]+Decimals;
- Str(Value:Width+8,Digits);
- { Find and cut out exponent. Always the
- last 6 characters in the string.
- -> 0000E+0000 }
- I:=Length(Digits)-5;
- Val(Copy(Digits,I+1,5),Exp,J);
- Exp:=Exp+1-(Placehold[1]+Placehold[2]);
- Delete(Digits, I, 6);
- { Str() always returns at least one digit after the decimal point.
- If we don't want it, we have to remove it. }
- If (Decimals=0) And (Placehold[1]+Placehold[2]<= 1) Then
- Begin
- If (Digits[4]>='5') Then
- Begin
- Inc(Digits[2]);
- If (Digits[2]>'9') Then
- Begin
- Digits[2] := '1';
- Inc(Exp);
- End;
- End;
- Delete(Digits, 3, 2);
- DecimalPoint := Length(Digits) + 1;
- End
- Else
- Begin
- { Move decimal point at the desired position }
- Delete(Digits, 3, 1);
- DecimalPoint:=2+Placehold[1]+Placehold[2];
- If (Decimals<>0) Then
- Insert('.',Digits,DecimalPoint);
- End;
- { Convert optional zeroes to spaces. }
- I := Length(Digits);
- J := DecimalPoint + Placehold[3];
- While (I > J) And (Digits[I] = '0') Do
- Begin
- Digits[I] := ' ';
- Dec(I);
- End;
- { If integer number and no obligatory decimal paces, remove decimal point }
- If (DecimalPoint<Length(Digits)) And
- (Digits[DecimalPoint+1]=' ') Then
- Digits[DecimalPoint]:=' ';
- If (Digits[1]=' ') Then
- Begin
- Delete(Digits, 1, 1);
- Dec(DecimalPoint);
- End;
- { Calculate exponent string }
- Str(Abs(Exp), Exponent);
- While Length(Exponent)<ExpSize Do
- Insert('0',Exponent,1);
- If Exp >= 0 Then
- Begin
- If (ExpFmt In [1,3]) Then
- Insert('+', Exponent, 1);
- End
- Else
- Insert('-',Exponent,1);
- If (ExpFmt<3) Then
- Insert('E',Exponent,1)
- Else
- Insert('e',Exponent,1);
- End;
- DigitExponent:=DecimalPoint-2;
- If (Digits[1]='-') Then
- Dec(DigitExponent);
- UnexpectedDigits:=DecimalPoint-1-(Placehold[1]+Placehold[2]);
- End;
- Function PutResult: LongInt;
- Var
- SQ, DQ: Boolean;
- Fmt, Buf: PChar;
- Dig, N: Integer;
- Begin
- SQ := False;
- DQ := False;
- Fmt := FmtStart;
- Buf := Buffer;
- Dig := 1;
- While (Fmt<FmtStop) Do
- Begin
- //Write(Fmt[0]);
- Case Fmt[0] Of
- #34:
- Begin
- If Not SQ Then
- DQ := Not DQ;
- Inc(Fmt);
- End;
- #39:
- Begin
- If Not DQ Then
- SQ := Not SQ;
- Inc(Fmt);
- End;
- Else
- If Not (SQ Or DQ) Then
- Begin
- Case Fmt[0] Of
- '0', '#', '.':
- Begin
- If (Dig=1) And (UnexpectedDigits>0) Then
- Begin
- { Everything unexpected is written before the first digit }
- For N := 1 To UnexpectedDigits Do
- Begin
- Buf[0] := Digits[N];
- Inc(Buf);
- If thousand And (Digits[N]<>'-') Then
- Begin
- If (DigitExponent Mod 3 = 0) And (DigitExponent>0) Then
- Begin
- Buf[0] := FormatSettings.ThousandSeparator;
- Inc(Buf);
- End;
- Dec(DigitExponent);
- End;
- End;
- Inc(Dig, UnexpectedDigits);
- End;
- If (Digits[Dig]<>' ') Then
- Begin
- If (Digits[Dig]='.') Then
- Buf[0] := FormatSettings.DecimalSeparator
- Else
- Buf[0] := Digits[Dig];
- Inc(Buf);
- If thousand And (DigitExponent Mod 3 = 0) And (DigitExponent > 0) Then
- Begin
- Buf[0] := FormatSettings.ThousandSeparator;
- Inc(Buf);
- End;
- End;
- Inc(Dig);
- Dec(DigitExponent);
- Inc(Fmt);
- End;
- 'e', 'E':
- Begin
- If ExpFmt <> 0 Then
- Begin
- Inc(Fmt);
- If Fmt < FmtStop Then
- Begin
- If Fmt[0] In ['+', '-'] Then
- Begin
- Inc(Fmt, ExpSize);
- For N:=1 To Length(Exponent) Do
- Buf[N-1] := Exponent[N];
- Inc(Buf,Length(Exponent));
- ExpFmt:=0;
- End;
- Inc(Fmt);
- End;
- End
- Else
- Begin
- { No legal exponential format.
- Simply write the 'E' to the result. }
- Buf[0] := Fmt[0];
- Inc(Buf);
- Inc(Fmt);
- End;
- End;
- Else { Case }
- { Usual character }
- If (Fmt[0]<>',') Then
- Begin
- Buf[0] := Fmt[0];
- Inc(Buf);
- End;
- Inc(Fmt);
- End; { Case }
- End
- Else { IF }
- Begin
- { Character inside single or double quotes }
- Buf[0] := Fmt[0];
- Inc(Buf);
- Inc(Fmt);
- End;
- End; { Case }
- End; { While .. Begin }
- Result:=PtrInt(Buf)-PtrInt(Buffer);
- End;
- Begin
- If (Value>0) Then
- GetSectionRange(1)
- Else If (Value<0) Then
- GetSectionRange(2)
- Else
- GetSectionRange(3);
- If FmtStart = Nil Then
- Begin
- Result := FloatToText(Buffer, Value, ffGeneral, 15, 4, FormatSettings);
- End
- Else
- Begin
- GetFormatOptions;
- If (ExpFmt = 0) And (Abs(Value) >= 1E18) Then
- Result := FloatToText(Buffer, Value, ffGeneral, 15, 4, FormatSettings)
- Else
- Begin
- FloatToStr;
- Result := PutResult;
- End;
- End;
- End;
- Procedure FloatToDecimal(Out Result: TFloatRec; const Value; ValueType: TFloatValue; Precision, Decimals : integer);
- var
- Buffer: String[254]; //Though str func returns only 25 chars, this might change in the future
- Error, N, L, Start, C: Integer;
- GotNonZeroBeforeDot, BeforeDot : boolean;
- begin
- case ValueType of
- fvExtended:
- Str(Extended(Value):25, Buffer);
- fvDouble,
- fvReal:
- Str(Double(Value):23, Buffer);
- fvSingle:
- Str(Single(Value):16, Buffer);
- fvCurrency:
- Str(Currency(Value):25, Buffer);
- fvComp:
- Str(Currency(Value):23, Buffer);
- end;
-
- N := 1;
- L := Byte(Buffer[0]);
- while Buffer[N]=' ' do
- Inc(N);
- Result.Negative := (Buffer[N] = '-');
- if Result.Negative then
- Inc(N);
- Start := N; //Start of digits
- Result.Exponent := 0; BeforeDot := true;
- GotNonZeroBeforeDot := false;
- while (L>=N) and (Buffer[N]<>'E') do
- begin
- if Buffer[N]='.' then
- BeforeDot := false
- else
- begin
- if BeforeDot then
- begin // Currently this is always 1 char
- Inc(Result.Exponent);
- Result.Digits[N-Start] := Buffer[N];
- if Buffer[N] <> '0' then
- GotNonZeroBeforeDot := true;
- end
- else
- Result.Digits[N-Start-1] := Buffer[N]
- end;
- Inc(N);
- end;
- Inc(N); // Pass through 'E'
- if N<=L then
- begin
- Val(Copy(Buffer, N, L-N+1), C, Error); // Get exponent after 'E'
- Inc(Result.Exponent, C);
- end;
- // Calculate number of digits we have from str
- if BeforeDot then
- N := N - Start - 1
- else
- N := N - Start - 2;
- L := SizeOf(Result.Digits);
- if N<L then
- FillChar(Result.Digits[N], L-N, '0'); //Zero remaining space
- if Decimals + Result.Exponent < Precision Then //After this it is the same as in FloatToDecimal
- N := Decimals + Result.Exponent
- Else
- N := Precision;
- if N >= L Then
- N := L-1;
- if N = 0 Then
- begin
- if Result.Digits[0] >= '5' Then
- begin
- Result.Digits[0] := '1';
- Result.Digits[1] := #0;
- Inc(Result.Exponent);
- end
- Else
- Result.Digits[0] := #0;
- end //N=0
- Else if N > 0 Then
- begin
- if Result.Digits[N] >= '5' Then
- begin
- Repeat
- Result.Digits[N] := #0;
- Dec(N);
- Inc(Result.Digits[N]);
- Until (N = 0) Or (Result.Digits[N] < ':');
- If Result.Digits[0] = ':' Then
- begin
- Result.Digits[0] := '1';
- Inc(Result.Exponent);
- end;
- end
- Else
- begin
- Result.Digits[N] := '0';
- While (N > -1) And (Result.Digits[N] = '0') Do
- begin
- Result.Digits[N] := #0;
- Dec(N);
- end;
- end;
- end //N>0
- Else
- Result.Digits[0] := #0;
- if (Result.Digits[0] = #0) and
- not GotNonZeroBeforeDot then
- begin
- Result.Exponent := 0;
- Result.Negative := False;
- end;
- end;
- Procedure FloatToDecimal(Out Result: TFloatRec; Value: Extended; Precision, Decimals : integer);
- begin
- FloatToDecimal(Result,Value,fvExtended,Precision,Decimals);
- end;
- Function FormatFloat(Const Format : String; Value : Extended; Const FormatSettings: TFormatSettings) : String;
- Var
- buf : Array[0..1024] of char;
- Begin
- Buf[FloatToTextFmt(@Buf[0],Value,Pchar(Format),FormatSettings)]:=#0;
- Result:=StrPas(@Buf[0]);
- End;
- Function FormatFloat(Const format: String; Value: Extended): String;
- begin
- Result:=FormatFloat(Format,Value,DefaultFormatSettings);
- end;
- Function FormatCurr(const Format: string; Value: Currency; Const FormatSettings: TFormatSettings): string;
- begin
- Result := FormatFloat(Format, Value,FormatSettings);
- end;
- function FormatCurr(const Format: string; Value: Currency): string;
- begin
- Result:=FormatCurr(Format,Value,DefaultFormatSettings);
- end;
- {==============================================================================}
- { extra functions }
- {==============================================================================}
- { LeftStr returns Count left-most characters from S }
- function LeftStr(const S: string; Count: integer): string;
- begin
- result := Copy(S, 1, Count);
- end ;
- { RightStr returns Count right-most characters from S }
- function RightStr(const S: string; Count: integer): string;
- begin
- If Count>Length(S) then
- Count:=Length(S);
- result := Copy(S, 1 + Length(S) - Count, Count);
- end;
- { BCDToInt converts the BCD value Value to an integer }
- function BCDToInt(Value: integer): integer;
- var i, j: integer;
- begin
- result := 0;
- j := 1;
- for i := 0 to SizeOf(Value) shr 1 - 1 do begin
- result := result + j * (Value and 15);
- j := j * 10;
- Value := Value shr 4;
- end ;
- end ;
- Function LastDelimiter(const Delimiters, S: string): Integer;
- begin
- Result:=Length(S);
- While (Result>0) and (Pos(S[Result],Delimiters)=0) do
- Dec(Result);
- end;
- Function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
- var
- Srch,OldP,RemS: string; // Srch and Oldp can contain uppercase versions of S,OldPattern
- P : Integer;
- begin
- Srch:=S;
- OldP:=OldPattern;
- if rfIgnoreCase in Flags then
- begin
- Srch:=AnsiUpperCase(Srch);
- OldP:=AnsiUpperCase(OldP);
- end;
- RemS:=S;
- Result:='';
- while (Length(Srch)<>0) do
- begin
- P:=AnsiPos(OldP, Srch);
- if P=0 then
- begin
- Result:=Result+RemS;
- Srch:='';
- end
- else
- begin
- Result:=Result+Copy(RemS,1,P-1)+NewPattern;
- P:=P+Length(OldP);
- RemS:=Copy(RemS,P,Length(RemS)-P+1);
- if not (rfReplaceAll in Flags) then
- begin
- Result:=Result+RemS;
- Srch:='';
- end
- else
- Srch:=Copy(Srch,P,Length(Srch)-P+1);
- end;
- end;
- end;
- Function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;
- begin
- Result:=False;
- If (Index>0) and (Index<=Length(S)) then
- Result:=Pos(S[Index],Delimiters)<>0; // Note we don't do MBCS yet
- end;
- Function ByteToCharLen(const S: string; MaxLen: Integer): Integer;
- begin
- Result:=Length(S);
- If Result>MaxLen then
- Result:=MaxLen;
- end;
- Function ByteToCharIndex(const S: string; Index: Integer): Integer;
- begin
- Result:=Index;
- end;
- Function CharToByteLen(const S: string; MaxLen: Integer): Integer;
- begin
- Result:=Length(S);
- If Result>MaxLen then
- Result:=MaxLen;
- end;
- Function CharToByteIndex(const S: string; Index: Integer): Integer;
- begin
- Result:=Index;
- end;
- Function ByteType(const S: string; Index: Integer): TMbcsByteType;
- begin
- Result:=mbSingleByte;
- end;
- Function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType;
- begin
- Result:=mbSingleByte;
- end;
- Function StrCharLength(const Str: PChar): Integer;
- begin
- result:=widestringmanager.CharLengthPCharProc(Str);
- end;
- Function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet;IgnoreCase: Boolean): Boolean;
- Var
- I,L : Integer;
- S,T : String;
- begin
- Result:=False;
- S:=Switch;
- If IgnoreCase then
- S:=UpperCase(S);
- I:=ParamCount;
- While (Not Result) and (I>0) do
- begin
- L:=Length(Paramstr(I));
- If (L>0) and (ParamStr(I)[1] in Chars) then
- begin
- T:=Copy(ParamStr(I),2,L-1);
- If IgnoreCase then
- T:=UpperCase(T);
- Result:=S=T;
- end;
- Dec(i);
- end;
- end;
- Function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean;
- begin
- Result:=FindCmdLineSwitch(Switch,SwitchChars,IgnoreCase);
- end;
- Function FindCmdLineSwitch(const Switch: string): Boolean;
- begin
- Result:=FindCmdLineSwitch(Switch,SwitchChars,False);
- end;
- function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; MaxCol: Integer): string;
- const
- Quotes = ['''', '"'];
- Var
- L : String;
- C,LQ,BC : Char;
- P,BLen,Len : Integer;
- HB,IBC : Boolean;
- begin
- Result:='';
- L:=Line;
- Blen:=Length(BreakStr);
- If (BLen>0) then
- BC:=BreakStr[1]
- else
- BC:=#0;
- Len:=Length(L);
- While (Len>0) do
- begin
- P:=1;
- LQ:=#0;
- HB:=False;
- IBC:=False;
- While ((P<=Len) and ((P<=MaxCol) or not IBC)) and ((LQ<>#0) or Not HB) do
- begin
- C:=L[P];
- If (C=LQ) then
- LQ:=#0
- else If (C in Quotes) then
- LQ:=C;
- If (LQ<>#0) then
- Inc(P)
- else
- begin
- HB:=((C=BC) and (BreakStr=Copy(L,P,BLen)));
- If HB then
- Inc(P,Blen)
- else
- begin
- If (P>MaxCol) then
- IBC:=C in BreakChars;
- Inc(P);
- end;
- end;
- // Writeln('"',C,'" : IBC : ',IBC,' HB : ',HB,' LQ : ',LQ,' P>MaxCol : ',P>MaxCol);
- end;
- Result:=Result+Copy(L,1,P-1);
- If Not HB then
- Result:=Result+BreakStr;
- Delete(L,1,P-1);
- Len:=Length(L);
- end;
- end;
- function WrapText(const Line: string; MaxCol: Integer): string;
- begin
- Result:=WrapText(Line,sLineBreak, [' ', '-', #9], MaxCol);
- end;
- {
- Case Translation Tables
- Can be used in internationalization support.
- Although these tables can be obtained through system calls
- it is better to not use those, since most implementation are not 100%
- WARNING:
- before modifying a translation table make sure that the current codepage
- of the OS corresponds to the one you make changes to
- }
- const
- { upper case translation table for character set 850 }
- CP850UCT: array[128..255] of char =
- (#128,#154,#144,#182,#142,#182,#143,#128,#210,#211,#212,#216,#215,#222,#142,#143,
- #144,#146,#146,#226,#153,#227,#234,#235,'Y',#153,#154,#157,#156,#157,#158,#159,
- #181,#214,#224,#233,#165,#165,#166,#167,#168,#169,#170,#171,#172,#173,#174,#175,
- #176,#177,#178,#179,#180,#181,#182,#183,#184,#185,#186,#187,#188,#189,#190,#191,
- #192,#193,#194,#195,#196,#197,#199,#199,#200,#201,#202,#203,#204,#205,#206,#207,
- #208,#209,#210,#211,#212,#213,#214,#215,#216,#217,#218,#219,#220,#221,#222,#223,
- #224,#225,#226,#227,#229,#229,#230,#237,#232,#233,#234,#235,#237,#237,#238,#239,
- #240,#241,#242,#243,#244,#245,#246,#247,#248,#249,#250,#251,#252,#253,#254,#255);
- { lower case translation table for character set 850 }
- CP850LCT: array[128..255] of char =
- (#135,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#132,#134,
- #130,#145,#145,#147,#148,#149,#150,#151,#152,#148,#129,#155,#156,#155,#158,#159,
- #160,#161,#162,#163,#164,#164,#166,#167,#168,#169,#170,#171,#172,#173,#174,#175,
- #176,#177,#178,#179,#180,#160,#131,#133,#184,#185,#186,#187,#188,#189,#190,#191,
- #192,#193,#194,#195,#196,#197,#198,#198,#200,#201,#202,#203,#204,#205,#206,#207,
- #208,#209,#136,#137,#138,#213,#161,#140,#139,#217,#218,#219,#220,#221,#141,#223,
- #162,#225,#147,#149,#228,#228,#230,#237,#232,#163,#150,#151,#236,#236,#238,#239,
- #240,#241,#242,#243,#244,#245,#246,#247,#248,#249,#250,#251,#252,#253,#254,#255);
- { upper case translation table for character set ISO 8859/1 Latin 1 }
- CPISO88591UCT: array[192..255] of char =
- ( #192, #193, #194, #195, #196, #197, #198, #199,
- #200, #201, #202, #203, #204, #205, #206, #207,
- #208, #209, #210, #211, #212, #213, #214, #215,
- #216, #217, #218, #219, #220, #221, #222, #223,
- #192, #193, #194, #195, #196, #197, #198, #199,
- #200, #201, #202, #203, #204, #205, #206, #207,
- #208, #209, #210, #211, #212, #213, #214, #247,
- #216, #217, #218, #219, #220, #221, #222, #89 );
- { lower case translation table for character set ISO 8859/1 Latin 1 }
- CPISO88591LCT: array[192..255] of char =
- ( #224, #225, #226, #227, #228, #229, #230, #231,
- #232, #233, #234, #235, #236, #237, #238, #239,
- #240, #241, #242, #243, #244, #245, #246, #215,
- #248, #249, #250, #251, #252, #253, #254, #223,
- #224, #225, #226, #227, #228, #229, #230, #231,
- #232, #233, #234, #235, #236, #237, #238, #239,
- #240, #241, #242, #243, #244, #245, #246, #247,
- #248, #249, #250, #251, #252, #253, #254, #255 );
- function sscanf(const s: string; const fmt : string;const Pointers : array of Pointer) : Integer;
- var
- i,j,n,m : SizeInt;
- s1 : string;
- function GetInt(unsigned : boolean=false) : Integer;
- begin
- s1 := '';
- while (Length(s) > n) and (s[n] = ' ') do
- inc(n);
- { read sign }
- if (Length(s)>= n) and (s[n] in ['+', '-']) then
- begin
- { don't accept - when reading unsigned }
- if unsigned and (s[n]='-') then
- begin
- result:=length(s1);
- exit;
- end
- else
- begin
- s1:=s1+s[n];
- inc(n);
- end;
- end;
- { read numbers }
- while (Length(s) >= n) and
- (s[n] in ['0'..'9']) do
- begin
- s1 := s1+s[n];
- inc(n);
- end;
- Result := Length(s1);
- end;
- function GetFloat : Integer;
- begin
- s1 := '';
- while (Length(s) > n) and (s[n] = ' ') do
- inc(n);
- while (Length(s) >= n) and
- (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) do
- begin
- s1 := s1+s[n];
- inc(n);
- end;
- Result := Length(s1);
- end;
- function GetString : Integer;
- begin
- s1 := '';
- while (Length(s) > n) and (s[n] = ' ') do
- inc(n);
- while (Length(s) >= n) and (s[n] <> ' ')do
- begin
- s1 := s1+s[n];
- inc(n);
- end;
- Result := Length(s1);
- end;
- function ScanStr(c : Char) : Boolean;
- begin
- while (Length(s) > n) and (s[n] <> c) do
- inc(n);
- inc(n);
- If (n <= Length(s)) then
- Result := True
- else
- Result := False;
- end;
- function GetFmt : Integer;
- begin
- Result := -1;
- while true do
- begin
- while (Length(fmt) > m) and (fmt[m] = ' ') do
- inc(m);
- if (m >= Length(fmt)) then
- break;
- if (fmt[m] = '%') then
- begin
- inc(m);
- case fmt[m] of
- 'd':
- Result:=vtInteger;
- 'f':
- Result:=vtExtended;
- 's':
- Result:=vtString;
- 'c':
- Result:=vtChar;
- else
- raise EFormatError.CreateFmt(SInvalidFormat,[fmt]);
- end;
- inc(m);
- break;
- end;
- if not(ScanStr(fmt[m])) then
- break;
- inc(m);
- end;
- end;
- begin
- n := 1;
- m := 1;
- Result := 0;
- for i:=0 to High(Pointers) do
- begin
- j := GetFmt;
- case j of
- vtInteger :
- begin
- if GetInt>0 then
- begin
- pLongint(Pointers[i])^:=StrToInt(s1);
- inc(Result);
- end
- else
- break;
- end;
- vtchar :
- begin
- if Length(s)>n then
- begin
- pchar(Pointers[i])^:=s[n];
- inc(n);
- inc(Result);
- end
- else
- break;
- end;
- vtExtended :
- begin
- if GetFloat>0 then
- begin
- pextended(Pointers[i])^:=StrToFloat(s1);
- inc(Result);
- end
- else
- break;
- end;
- vtString :
- begin
- if GetString > 0 then
- begin
- pansistring(Pointers[i])^:=s1;
- inc(Result);
- end
- else
- break;
- end;
- else
- break;
- end;
- end;
- end;
|