mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 21:07:58 +02:00
339 lines
8.6 KiB
ObjectPascal
339 lines
8.6 KiB
ObjectPascal
{ %norun }
|
|
|
|
{$mode delphi}
|
|
|
|
uses
|
|
sysutils
|
|
{$ifdef WINDOWS}
|
|
,windows
|
|
{$endif WINDOWS}
|
|
;
|
|
|
|
|
|
{$define use_inline }
|
|
|
|
function IndyMin(const AValueOne, AValueTwo: Int32): Int32;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne > AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
function IndyMin(const AValueOne, AValueTwo: Int64): Int64;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne > AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
function IndyMin(const AValueOne, AValueTwo: UInt16): UInt16;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne > AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
|
|
function IndyMax(const AValueOne, AValueTwo: Int64): Int64;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne < AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
function IndyMax(const AValueOne, AValueTwo: Int32): Int32;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne < AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
function IndyMax(const AValueOne, AValueTwo: UInt16): UInt16;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF} overload;
|
|
begin
|
|
if AValueOne < AValueTwo then begin
|
|
Result := AValueTwo;
|
|
end else begin
|
|
Result := AValueOne;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
function IndyLength(const ABuffer: String; const ALength: Integer = -1; const AIndex: Integer = 1): Integer;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
var
|
|
LAvailable: Integer;
|
|
begin
|
|
Assert(AIndex >= 1);
|
|
LAvailable := IndyMax(Length(ABuffer)-AIndex+1, 0);
|
|
if ALength < 0 then begin
|
|
Result := LAvailable;
|
|
end else begin
|
|
Result := IndyMin(LAvailable, ALength);
|
|
end;
|
|
end;
|
|
|
|
|
|
function CharEquals(const AString: string; const ACharPos: Integer; const AValue: Char): Boolean;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
begin
|
|
if ACharPos < 1 then begin
|
|
raise Exception.Create('Invalid ACharPos');{ do not localize }
|
|
end;
|
|
Result := ACharPos <= Length(AString);
|
|
if Result then begin
|
|
Result := AString[ACharPos] = AValue;
|
|
end;
|
|
end;
|
|
|
|
|
|
{$HINTS OFF}
|
|
function IsNumeric(const AString: string): Boolean; overload;
|
|
var
|
|
LCode: Integer;
|
|
LVoid: Int64;
|
|
begin
|
|
Val(AString, LVoid, LCode);
|
|
Result := LCode = 0;
|
|
end;
|
|
{$HINTS ON}
|
|
|
|
function IsNumeric(const AString: string; const ALength: Integer; const AIndex: Integer = 1): Boolean; overload;
|
|
var
|
|
I: Integer;
|
|
LLen: Integer;
|
|
begin
|
|
Result := False;
|
|
LLen := IndyLength(AString, ALength, AIndex);
|
|
if LLen > 0 then begin
|
|
for I := 0 to LLen-1 do begin
|
|
if not IsNumeric(AString[AIndex+i]) then begin
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function IsNumeric(const AChar: Char): Boolean; overload;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
begin
|
|
// TODO: under XE3.5+, use TCharHelper.IsDigit() instead
|
|
// TODO: under D2009+, use TCharacter.IsDigit() instead
|
|
|
|
// Do not use IsCharAlpha or IsCharAlphaNumeric - they are Win32 routines
|
|
Result := (AChar >= '0') and (AChar <= '9'); {Do not Localize}
|
|
end;
|
|
|
|
|
|
function StripNo(const AData : String): String; inline;
|
|
var
|
|
i : Integer;
|
|
LPos : Integer;
|
|
begin
|
|
LPos := 1;
|
|
for i := 1 to Length(AData) do begin
|
|
LPos := i;
|
|
if (not IsNumeric(AData[i])) and (not CharEquals(AData, i, ',')) then begin
|
|
Break;
|
|
end;
|
|
end;
|
|
Result := Copy(AData, LPos, Length(AData));
|
|
end;
|
|
|
|
function TextStartsWith(const S, SubS: string): Boolean;
|
|
var
|
|
LLen: Integer;
|
|
{$IFDEF WINDOWS}
|
|
{$IFDEF COMPARE_STRING_MISMATCH}
|
|
LS, LSubS: {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF};
|
|
P1, P2: {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF};
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
begin
|
|
LLen := Length(SubS);
|
|
Result := LLen <= Length(S);
|
|
if Result then
|
|
begin
|
|
{$IFDEF DOTNET}
|
|
Result := System.String.Compare(S, 0, SubS, 0, LLen, True) = 0;
|
|
{$ELSE}
|
|
{$IFDEF WINDOWS}
|
|
{$IFDEF COMPARE_STRING_MISMATCH}
|
|
// explicit convert to Ansi/Unicode
|
|
LS := {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF}(S);
|
|
LSubS := {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF}(SubS);
|
|
LLen := Length(LSubS);
|
|
Result := LLen <= Length(LS);
|
|
if Result then begin
|
|
P1 := {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF}(LS);
|
|
P2 := {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF}(LSubS);
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P1, LLen, P2, LLen) = 2;
|
|
end;
|
|
{$ELSE}
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S), LLen, PChar(SubS), LLen) = 2;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
Result := AnsiCompareText(Copy(S, 1, LLen), SubS) = 0;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure IdDelete(var s: string; AOffset, ACount: Integer);
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
begin
|
|
Delete(s, AOffset, ACount);
|
|
end;
|
|
|
|
function TextEndsWith(const S, SubS: string): Boolean;
|
|
var
|
|
LLen: Integer;
|
|
{$IFDEF WINDOWS}
|
|
{$IFDEF COMPARE_STRING_MISMATCH}
|
|
LS, LSubS: {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF};
|
|
P1, P2: {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF};
|
|
{$ELSE}
|
|
P: PChar;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
begin
|
|
LLen := Length(SubS);
|
|
Result := LLen <= Length(S);
|
|
if Result then
|
|
begin
|
|
{$IFDEF DOTNET}
|
|
Result := System.String.Compare(S, Length(S)-LLen, SubS, 0, LLen, True) = 0;
|
|
{$ELSE}
|
|
{$IFDEF WINDOWS}
|
|
{$IFDEF COMPARE_STRING_MISMATCH}
|
|
// explicit convert to Ansi/Unicode
|
|
LS := {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF}(S);
|
|
LSubS := {$IFDEF WINCE}TIdUnicodeString{$ELSE}TIdPlatformString{$ENDIF}(SubS);
|
|
LLen := Length(LSubS);
|
|
Result := LLen <= Length(S);
|
|
if Result then begin
|
|
P1 := {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF}(LS);
|
|
P2 := {$IFDEF WINCE}PIdWideChar{$ELSE}PIdPlatformChar{$ENDIF}(LSubS);
|
|
Inc(P1, Length(LS)-LLen);
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P1, LLen, P2, LLen) = 2;
|
|
end;
|
|
{$ELSE}
|
|
P := PChar(S);
|
|
Inc(P, Length(S)-LLen);
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P, LLen, PChar(SubS), LLen) = 2;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
Result := AnsiCompareText(Copy(S, Length(S)-LLen+1, LLen), SubS) = 0;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
const
|
|
IdFetchDelimDefault = ' '; {Do not Localize}
|
|
IdFetchDeleteDefault = True;
|
|
IdFetchCaseSensitiveDefault = True;
|
|
|
|
function FetchCaseInsensitive(var AInput: string; const ADelim: string;
|
|
const ADelete: Boolean): string;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
var
|
|
LPos: Integer;
|
|
begin
|
|
if ADelim = #0 then begin
|
|
// AnsiPos does not work with #0
|
|
LPos := Pos(ADelim, AInput);
|
|
end else begin
|
|
//? may be AnsiUpperCase?
|
|
LPos := Pos(UpperCase(ADelim), UpperCase(AInput));
|
|
end;
|
|
if LPos = 0 then begin
|
|
Result := AInput;
|
|
if ADelete then begin
|
|
AInput := ''; {Do not Localize}
|
|
end;
|
|
end else begin
|
|
Result := Copy(AInput, 1, LPos - 1);
|
|
if ADelete then begin
|
|
//faster than Delete(AInput, 1, LPos + Length(ADelim) - 1); because the
|
|
//remaining part is larger than the deleted
|
|
AInput := Copy(AInput, LPos + Length(ADelim), MaxInt);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function Fetch(var AInput: string; const ADelim: string = IdFetchDelimDefault;
|
|
const ADelete: Boolean = IdFetchDeleteDefault;
|
|
const ACaseSensitive: Boolean = IdFetchCaseSensitiveDefault): string;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
var
|
|
LPos: Integer;
|
|
begin
|
|
if ACaseSensitive then begin
|
|
if ADelim = #0 then begin
|
|
// AnsiPos does not work with #0
|
|
LPos := Pos(ADelim, AInput);
|
|
end else begin
|
|
LPos := Pos(ADelim, AInput);
|
|
end;
|
|
if LPos = 0 then begin
|
|
Result := AInput;
|
|
if ADelete then begin
|
|
AInput := ''; {Do not Localize}
|
|
end;
|
|
end
|
|
else begin
|
|
Result := Copy(AInput, 1, LPos - 1);
|
|
if ADelete then begin
|
|
//slower Delete(AInput, 1, LPos + Length(ADelim) - 1); because the
|
|
//remaining part is larger than the deleted
|
|
AInput := Copy(AInput, LPos + Length(ADelim), MaxInt);
|
|
end;
|
|
end;
|
|
end else begin
|
|
Result := FetchCaseInsensitive(AInput, ADelim, ADelete);
|
|
end;
|
|
end;
|
|
|
|
function ExtractRecFormat(const ARecFM : String): String;
|
|
{$IFDEF USE_INLINE} inline; {$ENDIF}
|
|
begin
|
|
Result := ARecFM;
|
|
if TextStartsWith(Result, '<') then begin
|
|
IdDelete(Result, 1, 1);
|
|
end;
|
|
if TextEndsWith(Result, '>') then begin
|
|
Result := Fetch(Result, '>');
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure test;
|
|
var
|
|
LTmp: string;
|
|
s: string;
|
|
begin
|
|
LTmp:='ac';
|
|
s:=ExtractRecFormat(StripNo(LTmp));
|
|
end;
|
|
|
|
begin
|
|
end.
|