{%MainUnit sysutils.pp} { ********************************************************************* Copyright (C) 1997, 1998 Gertjan Schouten See the file COPYING.FPC, included in this distribution, for details about the copyright. 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. ********************************************************************** 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; {$ifdef dummy} { declaring this breaks delphi compatibility and e.g. tw3721.pp } FUNCTION NewStr (Const S: ShortString): PShortString; VAR P: PShortString; BEGIN If (S = '') Then P := Nil Else Begin { Return nil } GetMem(P, Length(S) + 1); { Allocate memory } If (P<>Nil) Then P^ := S; { Hold string } End; NewStr := P; { Return result } END; {$endif dummy} { DisposeStr frees the memory occupied by S } procedure DisposeStr(S: PString); begin if S <> Nil then begin dispose(s); S:=nil; end; end; PROCEDURE DisposeStr (S: PShortString); BEGIN If (S <> Nil) Then FreeMem(S, Length(S^) + 1); { Release memory } 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 ; function IsLeadChar(C: AnsiChar): Boolean; inline; begin Result:=C in LeadBytes; end; function IsLeadChar(B: Byte): Boolean; inline; begin Result:=AnsiChar(B) in LeadBytes; end; Function InternalChangeCase(Const S : AnsiString; const Chars: TSysCharSet; const Adjustment: Longint): AnsiString; var i : Integer; P : PAnsiChar; Unique : Boolean; begin Result := S; if Result='' then exit; Unique:=false; P:=PAnsiChar(Result); for i:=1 to Length(Result) do begin if CharInSet(P^,Chars) then begin if not Unique then begin UniqueString(Result); p:=@Result[i]; Unique:=true; end; P^:=AnsiChar(Ord(P^)+Adjustment); end; Inc(P); end; end; { UpperCase returns a copy of S where all lowercase characters ( from a to z ) have been converted to uppercase } Function UpperCase(Const S : AnsiString) : AnsiString; begin Result:=InternalChangeCase(S,['a'..'z'],-32); end; function UpperCase(const s: ansistring; LocaleOptions: TLocaleOptions): ansistring; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=UpperCase(s); loUserLocale: Result:=AnsiUpperCase(s); 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 : AnsiString) : AnsiString; begin Result:=InternalChangeCase(S,['A'..'Z'],32); end; function LowerCase(const s: ansistring; LocaleOptions: TLocaleOptions): ansistring; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=LowerCase(s); loUserLocale: Result:=AnsiLowerCase(s); end; end; function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin {$IFDEF UNICODERTL} result:=LowerCase(widestring(V)); {ELSE} result:=LowerCase(ansistring(V)); {$ENDIF} 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 } {$IF SIZEOF(SIZEINT)>SIZEOF(INTEGER)} Function DoCapSizeInt(SI : SizeInt) : Integer; inline; begin if (SI<0) then result:=-1 else if (SI>0) then result:=1 else result:=0; end; {$DEFINE CAPSIZEINT:=DoCapSizeInt} {$ELSE} {$DEFINE CAPSIZEINT:=} {$ENDIF} function CompareStr(const S1, S2: string): Integer; var count, count1, count2: SizeInt; begin 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 // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(Count1-Count2); end; function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=CompareStr(S1,S2); loUserLocale: Result:=AnsiCompareStr(S1,S2); end; 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: PtrUInt): integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin If P1=P2 then Result:=0 else Result:=CompareByte(P1^,P2^,Length); end; function CompareMem(P1, P2: Pointer; Length: PtrUInt): Boolean;{$ifdef SYSUTILSINLINE}inline;{$endif} begin if P1=P2 then Result:=True else Result:=CompareByte(P1^,P2^,Length)=0; 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; overload; var i, count, count1, count2: sizeint; Chr1, Chr2: byte; P1, P2: PChar; begin Count1 := Length(S1); Count2 := Length(S2); if (Count1>Count2) then Count := Count2 else Count := Count1; i := 0; if count>0 then begin P1 := @S1[1]; P2 := @S2[1]; while i < Count do begin Chr1 := byte(p1^); Chr2 := byte(p2^); if Chr1 <> Chr2 then begin if Chr1 in [97..122] then dec(Chr1,32); if Chr2 in [97..122] then dec(Chr2,32); if Chr1 <> Chr2 then Break; end; Inc(P1); Inc(P2); Inc(I); end; end; if i < Count then result := Chr1-Chr2 else // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(Count1-Count2); end; function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=CompareText(S1,S2); loUserLocale: Result:=AnsiCompareText(S1,S2); end; end; function SameText(const s1,s2:String):Boolean; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin Result:=CompareText(S1,S2)=0; end; function SameText(const s1,s2:String; LocaleOptions: TLocaleOptions):Boolean; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=SameText(S1,S2); loUserLocale: Result:=AnsiSameText(S1,S2); end; end; function SameStr(const s1,s2:String):Boolean; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin Result:=CompareStr(S1,S2)=0; end; function SameStr(const s1,s2:String; LocaleOptions: TLocaleOptions):Boolean; overload;{$ifdef SYSUTILSINLINE}inline;{$endif} begin case LocaleOptions of loInvariantLocale: Result:=SameStr(S1,S2); loUserLocale: Result:=AnsiSameStr(S1,S2); end; end; {$ifndef FPC_NOGENERICANSIROUTINES} {==============================================================================} { Ansi string functions } { these functions rely on the character set loaded by the OS } {==============================================================================} type TCaseTranslationTable = array[0..255] of AnsiChar; var { Tables with upper and lowercase forms of character sets. MUST be initialized with the correct code-pages } UpperCaseTable: TCaseTranslationTable; LowerCaseTable: TCaseTranslationTable; function GenericAnsiUpperCase(const s: ansistring): ansistring; 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: ansistring): ansistring; 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: ansistring): 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: ansistring): 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 GenericAnsiStrComp(S1, S2: PAnsiChar): 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; While (Result=0) and (S1^<>#0) and (S2^<>#0) do begin Result:=Ord(S1^)-Ord(S2^); //!! Must be replaced by ansi characters !! Inc(S1); Inc(S2); end; 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: PAnsiChar): 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; While (Result=0) and (S1^<>#0) and (S2^<>#0) do begin Result:=Ord(LowerCaseTable[Ord(S1[0])])-Ord(LowerCaseTable[Ord(S2[0])]); //!! Must be replaced by ansi characters !! Inc(S1); Inc(S2); end; if (Result=0) and (s1[0]<>s2[0]) then //length(s1)<>length(s2) if s1[0]=#0 then Result:=-1 //s1 shorter than s2 else Result:=1; //s1 longer than s2 end; function GenericAnsiStrLComp(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt; Var I : PtrUInt; 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 (I=MaxLen) end; function GenericAnsiStrLIComp(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt; Var I : PtrUInt; 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 (I=MaxLen) end; function GenericAnsiStrLower(Str: PAnsiChar): PAnsiChar; 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: PAnsiChar): PAnsiChar; begin result := Str; if Str <> Nil then begin while Str^ <> #0 do begin Str^ := UpperCaseTable[byte(Str^)]; Str := Str + 1; end ; end ; end ; {$endif FPC_NOGENERICANSIROUTINES} 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 AnsiLastChar(const S: string): PAnsiChar; begin //!! No multibyte yet, so we return the last one. result:=StrEnd(PAnsiChar(pointer(S))); // strend checks for nil Dec(Result); end ; function AnsiStrLastChar(Str: PAnsiChar): PAnsiChar; 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 // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.CompareStrAnsiStringProc(s1,s2)); end; function AnsiCompareText(const S1, S2: string): integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.CompareTextAnsiStringProc(s1,s2)); end; function AnsiStrComp(S1, S2: PAnsiChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.StrCompAnsiStringProc(s1,s2)); end; function AnsiStrIComp(S1, S2: PAnsiChar): integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.StrICompAnsiStringProc(s1,s2)); end; function AnsiStrLComp(S1, S2: PAnsiChar; MaxLen: SizeUInt): Integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.StrLCompAnsiStringProc(s1,s2,maxlen)); end; function AnsiStrLIComp(S1, S2: PAnsiChar; MaxLen: SizeUint): Integer;{$ifdef SYSUTILSINLINE}inline;{$endif} begin // CAPSIZEINT is no-op if Sizeof(Sizeint)<=SizeOF(Integer) result:=CAPSIZEINT(widestringmanager.StrLICompAnsiStringProc(s1,s2,maxlen)); end; function AnsiStrLower(Str: PAnsiChar): PAnsiChar;{$ifdef SYSUTILSINLINE}inline;{$endif} begin result:=widestringmanager.StrLowerAnsiStringProc(Str); end; function AnsiStrUpper(Str: PAnsiChar): PAnsiChar;{$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: ansistring): ansistring; 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: ansistring): ansistring; 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: ansistring): ansistring; 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: PWideChar; Quote: WideChar): Widestring; var P,Q,R: PWideChar; begin result:=''; if Src=Nil then exit; P := Src; Q := StrEnd(P); if P=Q then exit; if P^<>quote then exit(strpas(P)); 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-PWideChar(@Result[1]))); end ; function AnsiExtractQuotedStr(var Src: PAnsiChar; Quote: AnsiChar): Ansistring; var P,Q,R: PAnsiChar; begin result:=''; if Src=Nil then exit; P := Src; Q := StrEnd(P); if P=Q then exit; if P^<>quote then exit(strpas(P)); 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-PAnsiChar(@Result[1]))); end ; function AnsiExtractQuotedStr(var Src: PWideChar; Quote: AnsiChar): Widestring; begin Result:=AnsiExtractQuotedStr(Src,WideChar(Quote)); end; { Change CRLF, CR or LF with the default for the current platform } function AdjustLineBreaks(const S: string): string; begin Result:=AdjustLineBreaks(S,DefaultTextLineBreakStyle); end; { Change CRLF, CR or LF with the indicated style } function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string; var Source,Dest: PAnsiChar; 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 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 If Digits=0 then Digits:=1; 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: QWord; Digits: integer): string; begin result:=IntToHex(Int64(Value),Digits); end; function IntToHex(Value: Int8): string; begin Result:=IntToHex(LongInt(Value) and $ff, 2*SizeOf(Int8)); end; function IntToHex(Value: UInt8): string; begin Result:=IntToHex(Value, 2*SizeOf(UInt8)); end; function IntToHex(Value: Int16): string; begin Result:=IntToHex(LongInt(Value) and $ffff, 2*SizeOf(Int16)); end; function IntToHex(Value: UInt16): string; begin Result:=IntToHex(Value, 2*SizeOf(UInt16)); end; function IntToHex(Value: Int32): string; begin Result:=IntToHex(Value, 2*SizeOf(Int32)); end; function IntToHex(Value: UInt32): string; begin Result:=IntToHex(LongInt(Value), 2*SizeOf(UInt32)); end; function IntToHex(Value: Int64): string; begin Result:=IntToHex(Value, 2*SizeOf(Int64)); end; function IntToHex(Value: UInt64): string; begin Result:=IntToHex(Value, 2*SizeOf(UInt64)); end; function TryStrToInt(const s: string; out i : Longint) : 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): Longint; begin if not(TryStrToInt(s,Result)) then raise EConvertError.createfmt(SInvalidInteger,[S]); end; function StrToInt64(const S: string): int64; begin if not(TryStrToInt64(s,Result)) then raise EConvertError.createfmt(SInvalidInteger,[S]); end; function TryStrToInt64(const s: string; Out i : int64) : boolean; var Error : word; begin Val(s, i, Error); TryStrToInt64:=Error=0 end; function StrToQWord(const s: string): QWord; begin if not(TryStrToQWord(s,Result)) then raise EConvertError.createfmt(SInvalidInteger,[S]); end; function StrToUInt64(const s: string): UInt64; begin result:=StrToQWord(s); end; function StrToDWord(const s: string): DWord; begin if not(TryStrToDWord(s,Result)) then raise EConvertError.createfmt(SInvalidInteger,[S]); end; function TryStrToDWord(const s: string; Out D: DWord): boolean; var Error : word; lq : QWord; begin Val(s, lq, Error); TryStrToDWord:=(Error=0) and (lq<=High(DWord)); if TryStrToDWord then D:=lq; end; function StrToUInt(const s: string): Cardinal; begin StrToUInt:=StrToDWord(s); end; function TryStrToUInt(const s: string; out C: Cardinal): Boolean; begin TryStrToUInt:=TryStrToDWord(s, C); end; function TryStrToQWord(const s: string; Out Q: QWord): boolean; var Error : word; begin Val(s, Q, Error); TryStrToQWord:=Error=0 end; function TryStrToUInt64(const s: string; Out u: UInt64): boolean; begin result:=TryStrToQWord(s,u); 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: Longint): Longint; begin if not(TryStrToInt(s,Result)) then result := Default; end; { StrToDWordDef converts the string S to an DWord value, Default is returned in case S does not represent a valid DWord value } function StrToDWordDef(const S: string; Default: DWord): DWord; begin if not(TryStrToDWord(s,Result)) then result := Default; end; function StrToUIntDef(const S: string; Default: Cardinal): Cardinal; begin Result:=StrToDWordDef(S, 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; begin if not(TryStrToInt64(s,Result)) 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; begin if not(TryStrToQWord(s,Result)) then result := Default; end; function StrToUInt64Def(const S: string; Default: UInt64): UInt64; begin result:=StrToQWordDef(S,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;const fmt:ansistring); Var S : String; begin //!! must be changed to contain format string... S:=fmt; 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:=AnsiChar} 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 SafeFormat (const Fmt: AnsiString; Args: array of const): UTF8String; begin Result:=SafeFormat(Fmt,Args,DefaultFormatSettings); end; function SafeFormat (const Fmt: AnsiString; Args: array of const; const FormatSettings: TFormatSettings): UTF8String; begin try Result:=Format(Fmt,Args,FormatSettings); except On E : Exception do Result:='Error "'+E.ClassName+'" during format('''+Fmt+''',['+ArrayOfConstToStr(Args,',','{','}')+']) : '+E.Message; end; end; Function FormatBuf (Var Buffer; BufLen : Cardinal; Const Fmt; fmtLen : Cardinal; Const Args : Array of const; Const FormatSettings: TFormatSettings) : Cardinal; Var S,F : AnsiString; begin Setlength(F,fmtlen); if fmtlen > 0 then Move(fmt,F[1],fmtlen); S:=Format (F,Args,FormatSettings); If Cardinal(Length(S)) FormatSettings.DecimalSeparator) and (Pos(FormatSettings.ThousandSeparator, S) <> 0) then begin Result := False; Exit; end; if (FormatSettings.DecimalSeparator <> '.') and (Pos('.', S) <>0) then begin Result := False; Exit; end; P:=Pos(FormatSettings.DecimalSeparator,S); If (P<>0) Then S[P] := '.'; try Val(trim(S),Value,E); { on x87, a floating point exception may be pending in case of an invalid input value -> trigger it now } {$if defined(cpui386) or (defined(cpux86_64) and not(defined(win64))) or defined(cpui8086)} asm fwait end; {$endif} except E:=1; end; Result:=(E=0); End; Function TextToFloat(Buffer: PChar; Out Value: Extended): Boolean; begin Result:=TextToFloat(Buffer,Value,DefaultFormatSettings); end; Function TextToFloat(Buffer: PChar; Out Value; ValueType: TFloatValue): Boolean; begin Result:=TextToFloat(Buffer,Value,ValueType,DefaultFormatSettings); end; Function TextToFloat(Buffer: PChar; Out Value; ValueType: TFloatValue; Const FormatSettings: TFormatSettings): Boolean; Var E,P : Integer; S : String; Begin S:=StrPas(Buffer); //ThousandSeparator not allowed as by Delphi specs if (FormatSettings.ThousandSeparator <> FormatSettings.DecimalSeparator) and (Pos(FormatSettings.ThousandSeparator, S) <> 0) then begin Result := False; Exit; end; if (FormatSettings.DecimalSeparator <> '.') and (Pos('.', S) <>0) then begin Result := False; Exit; end; P:=Pos(FormatSettings.DecimalSeparator,S); If (P<>0) Then S[P] := '.'; s:=Trim(s); try case ValueType of fvCurrency: Val(S,Currency(Value),E); 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; { on x87, a floating point exception may be pending in case of an invalid input value -> trigger it now } {$if defined(cpui386) or (defined(cpux86_64) and not(defined(win64))) or defined(cpui8086)} asm fwait end; {$endif} except E:=1; end; Result:=(E=0); End; Function TryStrToFloat(Const S : String; Out Value: Single): Boolean; begin Result:=TryStrToFloat(S,Value,DefaultFormatSettings); end; Function TryStrToFloat(Const S : String; Out Value: Single; Const FormatSettings: TFormatSettings): Boolean; Begin Result := TextToFloat(PChar(pointer(S)), Value, fvSingle,FormatSettings); End; Function TryStrToFloat(Const S : String; Out Value: Double): Boolean; begin Result:=TryStrToFloat(S,Value,DefaultFormatSettings); end; Function TryStrToFloat(Const S : String; Out Value: Double; Const FormatSettings: TFormatSettings): Boolean; Begin Result := TextToFloat(PChar(pointer(S)), Value, fvDouble,FormatSettings); End; {$ifdef FPC_HAS_TYPE_EXTENDED} Function TryStrToFloat(Const S : String; Out Value: Extended): Boolean; begin Result:=TryStrToFloat(S,Value,DefaultFormatSettings); end; Function TryStrToFloat(Const S : String; Out Value: Extended; Const FormatSettings: TFormatSettings): Boolean; Begin Result := TextToFloat(PChar(pointer(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, PE, Q, Exponent: Integer; Negative: Boolean; DS: Char; function RemoveLeadingNegativeSign(var AValue: String): Boolean; // removes negative sign in case when result is zero eg. -0.00 var i: PtrInt; TS: Char; StartPos: PtrInt; begin Result := False; if Format = ffCurrency then StartPos := 1 else StartPos := 2; TS := FormatSettings.ThousandSeparator; for i := StartPos to length(AValue) do begin Result := (AValue[i] in ['0', DS, 'E', '+', TS]); if not Result then break; end; if (Result) and (Format <> ffCurrency) then Delete(AValue, 1, 1); end; Begin DS:=FormatSettings.DecimalSeparator; Case format Of ffGeneral: Begin case ValueType of fvCurrency: If (Precision = -1) Or (Precision > 19) Then Precision := 19; else If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits; end; { First convert to scientific format, with correct precision } case ValueType of fvDouble: Str(Double(Extended(Aligned(Value))):precision+7, Result); fvSingle: Str(Single(Extended(Aligned(Value))):precision+6, Result); fvCurrency: Str(Currency(Aligned(Value)):precision+6, Result); else Str(Extended(Aligned(Value)):precision+8, Result); end; { Delete leading spaces } while Result[1] = ' ' do System.Delete(Result, 1, 1); P := Pos('.', Result); if P<>0 then Result[P] := DS else Exit; { NAN or other special case } { Consider removing exponent } PE:=Pos('E',Result); if PE > 0 then begin { Read exponent } Q := PE+2; Exponent := 0; while (Q <= Length(Result)) do begin Exponent := Exponent*10 + Ord(Result[Q])-Ord('0'); Inc(Q); end; if Result[PE+1] = '-' then Exponent := -Exponent; if (P+Exponent < PE) and (Exponent > -6) then begin { OK to remove exponent } SetLength(Result,PE-1); { Trim exponent } if Exponent >= 0 then begin { Shift point to right } for Q := 0 to Exponent-1 do begin Result[P] := Result[P+1]; Inc(P); end; Result[P] := DS; P := 1; if Result[P] = '-' then Inc(P); while (Result[P] = '0') and (P < Length(Result)) and (Result[P+1] <> DS) do { Trim leading zeros; conversion above should not give any, but occasionally does because of rounding } System.Delete(Result,P,1); end else begin { Add zeros at start } Insert(Copy('00000',1,-Exponent),Result,P-1); Result[P-Exponent] := Result[P-Exponent-1]; { Copy leading digit } Result[P] := DS; if Exponent <> -1 then Result[P-Exponent-1] := '0'; end; { Remove trailing zeros } Q := Length(Result); while (Q > 0) and (Result[Q] = '0') do Dec(Q); if Result[Q] = DS then Dec(Q); { Remove trailing decimal point } if (Q = 0) or ((Q=1) and (Result[1] = '-')) then Result := '0' else SetLength(Result,Q); end else begin { Need exponent, but remove superfluous characters } { Delete trailing zeros } while Result[PE-1] = '0' do begin System.Delete(Result,PE-1,1); Dec(PE); end; { If number ends in decimal point, remove it } if Result[PE-1] = DS then begin System.Delete(Result,PE-1,1); Dec(PE); end; { delete superfluous + in exponent } if Result[PE+1]='+' then System.Delete(Result,PE+1,1) else Inc(PE); while Result[PE+1] = '0' do { Delete leading zeros in exponent } System.Delete(Result,PE+1,1) end; end; End; ffExponent: Begin If (Precision = -1) Or (Precision > maxdigits) Then Precision := maxdigits; case ValueType of fvDouble: Str(Double(Extended(Aligned(Value))):Precision+7, Result); fvSingle: Str(Single(Extended(Aligned(Value))):Precision+6, Result); fvCurrency: Str(Currency(Aligned(Value)):Precision+6, Result); else Str(Extended(Aligned(Value)):Precision+8, Result); end; { Delete leading spaces } while Result[1] = ' ' do System.Delete(Result, 1, 1); if (Result[1]='-') and { not Nan etc.? } (Result[3]='.') then Result[3] := DS else if Result[2]='.' then 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(Aligned(Value))):0:Digits, Result); fvSingle: Str(Single(Extended(Aligned(Value))):0:Digits, Result); fvCurrency: Str(Currency(Aligned(Value)):0:Digits, Result); else Str(Extended(Aligned(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(Aligned(Value))):0:Digits, Result); fvSingle: Str(Single(Extended(Aligned(Value))):0:Digits, Result); fvCurrency: Str(Currency(Aligned(Value)):0:Digits, Result); else Str(Extended(Aligned(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] <> '-') And (FormatSettings.ThousandSeparator <> #0) 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(Aligned(Value))):0:Digits, Result); fvSingle: Str(Single(Extended(Aligned(Value))):0:Digits, Result); fvCurrency: Str(Currency(Aligned(Value)):0:Digits, Result); else Str(Extended(Aligned(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 else P := Length(Result)+1; Dec(P, 3); While (P > 1) Do Begin If FormatSettings.ThousandSeparator<>#0 Then Insert(FormatSettings.ThousandSeparator, Result, P); Dec(P, 3); End; if (length(Result) > 1) and Negative then Negative := not RemoveLeadingNegativeSign(Result); 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 FormatSettings.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 := Result + ' ' + FormatSettings.CurrencyString + '-'; 11: Result := FormatSettings.CurrencyString + ' ' + Result + '-'; 12: Result := FormatSettings.CurrencyString + ' ' + '-' + Result; 13: Result := Result + '-' + ' ' + FormatSettings.CurrencyString; 14: Result := '(' + FormatSettings.CurrencyString + ' ' + Result + ')'; 15: Result := '(' + Result + ' ' + FormatSettings.CurrencyString + ')'; End; End; End; End; if not (format in [ffCurrency]) and (length(Result) > 1) and (Result[1] = '-') then RemoveLeadingNegativeSign(Result); End; {$macro off} {$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: PAnsiChar; 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: PWideChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer; Const FormatSettings: TFormatSettings): Longint; Var Tmp: UnicodeString; Begin Tmp := FloatToStrF(Value, format, Precision, Digits,FormatSettings); Result := Length(Tmp); Move(Tmp[1], Buffer[0], Result*SizeOf(WideChar)); End; Function FloatToText(Buffer: PAnsiChar; Value: Extended; format: TFloatFormat; Precision, Digits: Integer): Longint; begin Result:=FloatToText(Buffer,Value,Format,Precision,Digits,DefaultFormatSettings); end; Function FloatToText(Buffer: PWideChar; 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 (ValueMaxDateTime) then Raise EConvertError.CreateFmt (SInvalidDateTimeFloat,[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 CurrToStr(Value: Currency; Const FormatSettings: TFormatSettings): string; begin Result:=FloatToStrF(Value,ffGeneral,-1,0,FormatSettings); end; function StrToCurr(const S: string): Currency; begin if not TextToFloat(PChar(pointer(S)), Result, fvCurrency) then Raise EConvertError.createfmt(SInValidFLoat,[S]); end; function StrToCurr(const S: string; Const FormatSettings: TFormatSettings): Currency; begin if not TextToFloat(PChar(pointer(S)), Result, fvCurrency,FormatSettings) then Raise EConvertError.createfmt(SInValidFLoat,[S]); end; Function TryStrToCurr(Const S : String; Out Value: Currency): Boolean; Begin Result := TextToFloat(PChar(pointer(S)), Value, fvCurrency); End; function TryStrToCurr(const S: string;Out Value : Currency; Const FormatSettings: TFormatSettings): Boolean; Begin Result := TextToFloat(PChar(pointer(S)), Value, fvCurrency,FormatSettings); End; function StrToCurrDef(const S: string; Default : Currency): Currency; begin if not TextToFloat(PChar(pointer(S)), Result, fvCurrency) then Result:=Default; end; function StrToCurrDef(const S: string; Default : Currency; Const FormatSettings: TFormatSettings): Currency; begin if not TextToFloat(PChar(pointer(S)), Result, fvCurrency,FormatSettings) then Result:=Default; end; {$endif FPUNONE} function AnsiDequotedStr(const S: string; AQuote: Char): string; var p : PChar; begin p:=PChar(pointer(s)); // work around CONST. Ansiextract is safe for nil result:=AnsiExtractquotedStr(p,AQuote); end; function StrToBool(const S: string): Boolean; begin if not(TryStrToBool(S,Result,DefaultFormatSettings)) then Raise EConvertError.CreateFmt(SInvalidBoolean,[S]); end; function StrToBool(const S: string; const FormatSettings: TFormatSettings): Boolean; begin if not(TryStrToBool(S,Result,FormatSettings)) then Raise EConvertError.CreateFmt(SInvalidBoolean,[S]); end; procedure CheckBoolStrs; 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; function BoolToStr(B: Boolean;UseBoolStrs:Boolean=False): string; begin if UseBoolStrs Then begin CheckBoolStrs; if B then Result:=TrueBoolStrs[0] else Result:=FalseBoolStrs[0]; end else If B then Result:='-1' else Result:='0'; end; // from textmode IDE util funcs. function BoolToStr(B: boolean; const TrueS, FalseS: string): string; begin if B then Result:=TrueS else BoolToStr:=FalseS; end; function StrToBoolDef(const S: string; Default: Boolean): Boolean; begin if not(TryStrToBool(S,Result)) then Result:=Default; end; function StrToBoolDef(const S: string; Default: Boolean; const FormatSettings: TFormatSettings): Boolean; begin if not(TryStrToBool(S,Result,FormatSettings)) then Result:=Default; end; function TryStrToBool(const S: string; out Value: Boolean): Boolean; begin Result:=TryStrToBool(S,Value,DefaultFormatSettings); end; function TryStrToBool(const S: string; out Value: Boolean; const FormatSettings: TFormatSettings): Boolean; Var Temp : String; I : Longint; {$ifdef FPUNONE} D : Longint; {$else} D : Double; {$endif} Code: word; begin Temp:=upcase(S); Val(temp,D,code); Result:=true; If (Code=0) or TryStrToFloat(S,D,FormatSettings) then {$ifdef FPUNONE} Value:=(D<>0) {$else} Value:=(D<>0.0) {$endif} else begin CheckBoolStrs; for I:=low(TrueBoolStrs) to High(TrueBoolStrs) do if Temp=upcase(TrueBoolStrs[I]) then begin Value:=true; exit; end; for I:=low(FalseBoolStrs) to High(FalseBoolStrs) do if Temp=upcase(FalseBoolStrs[I]) then begin Value:=false; exit; end; Result:=false; end; end; {$ifndef FPUNONE} Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar): Integer; begin Result:=FloatToTextFmt(Buffer,Value,Format,DefaultFormatSettings); end; {$MACRO ON} {$define FPChar:=PAnsiChar} {$define FChar:=AnsiChar} {$define FString:=AnsiString} {$I fmtflt.inc} {$undef FPChar} {$undef FChar} {$undef FString} {$MACRO ON} {$define FPChar:=PWideChar} {$define FChar:=WideChar} {$define FString:=UnicodeString} {$I fmtflt.inc} {$define FPChar:=PAnsiChar} {$define FChar:=AnsiChar} {$define FString:=AnsiString} Function FloatToTextFmt(Buffer: PChar; Value: Extended; format: PChar; FormatSettings : TFormatSettings): Integer; begin Result:=IntFloatToTextFmt(Buffer,Value,fvExtended,Format,FormatSettings); 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 InfNan: string[3]; 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) else if (Buffer[N] = '+') then inc(N); { special cases for Inf and Nan } if (L>=N+2) then begin InfNan:=copy(Buffer,N,3); if (InfNan='Inf') then begin Result.Digits[0]:=#0; Result.Exponent:=32767; exit end; if (InfNan='Nan') then begin Result.Digits[0]:=#0; Result.Exponent:=-32768; exit end; end; 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 AnsiChar 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 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; Len: Integer; Begin Len:=FloatToTextFmt(PChar(@Buf[0]),Value,PChar(Format),FormatSettings); Buf[Len]:=#0; Result:=StrPas(Pchar(@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; {$endif} {==============================================================================} { 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, digit: integer; begin result := 0; j := 1; for i := 0 to SizeOf(Value) shl 1 - 1 do begin digit := Value and 15; if digit > $9 then begin if i = 0 then begin if digit in [$B, $D] then j := -1 end else raise EConvertError.createfmt(SInvalidBCD,[Value]); end else begin result := result + j * digit; j := j * 10; end ; Value := Value shr 4; end ; end ; Function LastDelimiter(const Delimiters, S: string): SizeInt; var chs: TSysCharSet; I: SizeInt; begin chs := []; for I := 1 to Length(Delimiters) do Include(chs, Delimiters[I]); Result:=Length(S); While (Result>0) and not (S[Result] in chs) do Dec(Result); end; {$macro on} {$define INSTRINGREPLACE} {$define SRString:=AnsiString} {$define SRUpperCase:=AnsiUppercase} {$define SRPCHAR:=PAnsiChar} {$define SRCHAR:=AnsiChar} Function StringReplace(const S, OldPattern, NewPattern: Ansistring; Flags: TReplaceFlags): Ansistring; Var C : Integer; begin Result:=StringReplace(S,OldPattern,NewPattern,Flags,C); end; function StringReplace(const S, OldPattern, NewPattern: Ansistring; Flags: TReplaceFlags; Out aCount : Integer): Ansistring; {$i syssr.inc} {$undef INSTRINGREPLACE} {$undef SRString} {$undef SRUpperCase} {$undef SRPCHAR} {$undef SRCHAR} Function IsDelimiter(const Delimiters, S: string; Index: SizeInt): 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: SizeInt): SizeInt; begin Result:=Length(S); If Result>MaxLen then Result:=MaxLen; end; Function ByteToCharIndex(const S: string; Index: SizeInt): SizeInt; begin Result:=Index; end; Function CharToByteLen(const S: string; MaxLen: SizeInt): SizeInt; begin Result:=Length(S); If Result>MaxLen then Result:=MaxLen; end; Function CharToByteIndex(const S: string; Index: SizeInt): SizeInt; begin Result:=Index; end; Function ByteType(const S: string; Index: SizeUInt): TMbcsByteType; begin Result:=mbSingleByte; end; Function StrByteType(Str: PAnsiChar; Index: SizeUInt): TMbcsByteType; begin Result:=mbSingleByte; end; Function StrCharLength(const Str: PAnsiChar): SizeInt; begin result:=widestringmanager.CharLengthPCharProc(Str); end; function StrNextChar(const Str: PAnsiChar): PAnsiChar; begin result:=Str+StrCharLength(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 : AnsiChar; 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); Delete(L,1,P-1); Len:=Length(L); If (Len>0) and Not HB then Result:=Result+BreakStr; end; end; function WrapText(const Line: string; MaxCol: Integer): string; begin Result:=WrapText(Line,sLineBreak, [' ', '-', #9], MaxCol); end; {$ifndef FPC_NOGENERICANSIROUTINES} { Case Translation Tables Can be used in internationalization support. Although these tables can be obtained through system calls cd 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 {$if defined(MSDOS) or defined(GO32V2) or defined(WATCOM) or defined(WIN16) } { upper case translation table for character set 850 } CP850UCT: array[128..255] of AnsiChar = (#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 AnsiChar = (#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); {$endif} { upper case translation table for character set ISO 8859/1 Latin 1 } CPISO88591UCT: array[192..255] of AnsiChar = ( #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 AnsiChar = ( #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 ); {$endif FPC_NOGENERICANSIROUTINES} 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', '+', '-', FormatSettings.DecimalSeparator, '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 : AnsiChar) : 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; {$ifndef FPUNONE} 'f': Result:=vtExtended; {$endif} '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; {$ifndef FPUNONE} vtExtended : begin if GetFloat>0 then begin pextended(Pointers[i])^:=StrToFloat(s1); inc(Result); end else break; end; {$endif} vtString : begin if GetString > 0 then begin pstring(Pointers[i])^:=s1; inc(Result); end else break; end; else break; end; end; end; {$macro on} // Ansi version declaration {$UNDEF SBUNICODE} {$define SBChar:=AnsiChar} {$define SBString:=AnsiString} {$define TSBCharArray:=Array of SBChar} {$define PSBChar:=PAnsiChar} {$define SBRAWString:=RawByteString} {$define TGenericStringBuilder:=TAnsiStringBuilder} {$i syssb.inc} {$undef SBChar} {$undef SBString} {$undef TSBCharArray} {$undef PSBChar} {$undef SBRAWString} {$undef TGenericStringBuilder} // Unicode version declaration {$define SBUNICODE} {$define SBChar:=WideChar} {$define SBString:=UnicodeString} {$define TSBCharArray:=Array of SBChar} {$define PSBChar:=PWideChar} {$define SBRAWString:=UnicodeString} {$define TGenericStringBuilder:=TUnicodeStringBuilder} {$i syssb.inc} {$undef SBChar} {$undef SBString} {$undef TSBCharArray} {$undef PSBChar} {$undef SBRAWString} {$undef TGenericStringBuilder} {$undef SBUNICODE}