Archivado/Componentes.Terceros.jcl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
17dcd15e37
Componentes.Terceros.jcl/official/1.96/source/common/JclStrings.pas

4346 lines
109 KiB
ObjectPascal
Raw Blame History

{**************************************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
{ License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
{ and limitations under the License. }
{ }
{ The Original Code is JclStrings.pas. }
{ }
{ The Initial Developer of the Original Code is Marcel van Brakel. }
{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }
{ }
{ Contributor(s): }
{ Alexander Radchenko }
{ Andreas Hausladen }
{ Anthony Steele }
{ Azret Botash }
{ Barry Kelly }
{ Huanlin Tsai }
{ Jack N.A. Bakker }
{ Jean-Fabien Connault }
{ John C Molyneux }
{ Leonard Wennekers }
{ Martin Kimmings }
{ Martin Kubecka }
{ Massimo Maria Ghisalberti }
{ Matthias Thoma (mthoma) }
{ Michael Winter }
{ Nick Hodges }
{ Olivier Sannier }
{ Pelle F. S. Liljendal }
{ Petr Vones }
{ Rik Barker (rikbarker) }
{ Robert Lee }
{ Robert Marquardt }
{ Robert Rossmair (rrossmair) }
{ }
{**************************************************************************************************}
{ }
{ Various character and string routines (searching, testing and transforming) }
{ }
{**************************************************************************************************}
// Last modified: $Date: 2006/01/15 19:10:44 $
// For history see end of file
unit JclStrings;
{$I jcl.inc}
interface
uses
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF MSWINDOWS}
Classes, SysUtils,
{$IFDEF CLR}
System.Text,
{$ELSE}
JclWideStrings,
{$ENDIF CLR}
JclBase;
// Character constants and sets
const
// Misc. often used character definitions
AnsiNull = Char(#0);
AnsiSoh = Char(#1);
AnsiStx = Char(#2);
AnsiEtx = Char(#3);
AnsiEot = Char(#4);
AnsiEnq = Char(#5);
AnsiAck = Char(#6);
AnsiBell = Char(#7);
AnsiBackspace = Char(#8);
AnsiTab = Char(#9);
AnsiLineFeed = JclBase.AnsiLineFeed;
AnsiVerticalTab = Char(#11);
AnsiFormFeed = Char(#12);
AnsiCarriageReturn = JclBase.AnsiCarriageReturn;
AnsiCrLf = JclBase.AnsiCrLf;
AnsiSo = Char(#14);
AnsiSi = Char(#15);
AnsiDle = Char(#16);
AnsiDc1 = Char(#17);
AnsiDc2 = Char(#18);
AnsiDc3 = Char(#19);
AnsiDc4 = Char(#20);
AnsiNak = Char(#21);
AnsiSyn = Char(#22);
AnsiEtb = Char(#23);
AnsiCan = Char(#24);
AnsiEm = Char(#25);
AnsiEndOfFile = Char(#26);
AnsiEscape = Char(#27);
AnsiFs = Char(#28);
AnsiGs = Char(#29);
AnsiRs = Char(#30);
AnsiUs = Char(#31);
AnsiSpace = Char(' ');
AnsiComma = Char(',');
AnsiBackslash = Char('\');
AnsiForwardSlash = Char('/');
AnsiDoubleQuote = Char('"');
AnsiSingleQuote = Char('''');
AnsiLineBreak = JclBase.AnsiLineBreak;
// Misc. character sets
AnsiWhiteSpace = [AnsiTab, AnsiLineFeed, AnsiVerticalTab,
AnsiFormFeed, AnsiCarriageReturn, AnsiSpace];
AnsiSigns = ['-', '+'];
AnsiUppercaseLetters = JclBase.AnsiUppercaseLetters;
AnsiLowercaseLetters = JclBase.AnsiLowercaseLetters;
AnsiLetters = JclBase.AnsiLetters;
AnsiDecDigits = JclBase.AnsiDecDigits;
AnsiOctDigits = JclBase.AnsiOctDigits;
AnsiHexDigits = JclBase.AnsiHexDigits;
AnsiValidIdentifierLetters = JclBase.AnsiValidIdentifierLetters;
const
// CharType return values
C1_UPPER = $0001; // Uppercase
C1_LOWER = $0002; // Lowercase
C1_DIGIT = $0004; // Decimal digits
C1_SPACE = $0008; // Space characters
C1_PUNCT = $0010; // Punctuation
C1_CNTRL = $0020; // Control characters
C1_BLANK = $0040; // Blank characters
C1_XDIGIT = $0080; // Hexadecimal digits
C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic
{$IFDEF MSWINDOWS}
{$IFDEF SUPPORTS_EXTSYM}
{$EXTERNALSYM C1_UPPER}
{$EXTERNALSYM C1_LOWER}
{$EXTERNALSYM C1_DIGIT}
{$EXTERNALSYM C1_SPACE}
{$EXTERNALSYM C1_PUNCT}
{$EXTERNALSYM C1_CNTRL}
{$EXTERNALSYM C1_BLANK}
{$EXTERNALSYM C1_XDIGIT}
{$EXTERNALSYM C1_ALPHA}
{$ENDIF SUPPORTS_EXTSYM}
{$ENDIF MSWINDOWS}
// String Test Routines
function StrIsAlpha(const S: string): Boolean;
function StrIsAlphaNum(const S: string): Boolean;
function StrIsAlphaNumUnderscore(const S: string): Boolean;
function StrContainsChars(const S: string; Chars: TSysCharSet; CheckAll: Boolean): Boolean;
function StrConsistsOfNumberChars(const S: string): Boolean;
function StrIsDigit(const S: string): Boolean;
function StrIsSubset(const S: string; const ValidChars: TSysCharSet): Boolean;
function StrSame(const S1, S2: string): Boolean;
// String Transformation Routines
function StrCenter(const S: string; L: Integer; C: Char = ' '): string;
function StrCharPosLower(const S: string; CharPos: Integer): string;
function StrCharPosUpper(const S: string; CharPos: Integer): string;
function StrDoubleQuote(const S: string): string;
function StrEnsureNoPrefix(const Prefix, Text: string): string;
function StrEnsureNoSuffix(const Suffix, Text: string): string;
function StrEnsurePrefix(const Prefix, Text: string): string;
function StrEnsureSuffix(const Suffix, Text: string): string;
function StrEscapedToString(const S: string): string;
function StrLower(const S: string): string;
procedure StrLowerInPlace(var S: string);
{$IFNDEF CLR}
procedure StrLowerBuff(S: PChar);
{$ENDIF ~CLR}
procedure StrMove(var Dest: string; const Source: string; const ToIndex,
FromIndex, Count: Integer);
function StrPadLeft(const S: string; Len: Integer; C: Char = AnsiSpace ): string;
function StrPadRight(const S: string; Len: Integer; C: Char = AnsiSpace ): string;
function StrProper(const S: string): string;
{$IFNDEF CLR}
procedure StrProperBuff(S: PChar);
{$ENDIF ~CLR}
function StrQuote(const S: string; C: Char): string;
function StrRemoveChars(const S: string; const Chars: TSysCharSet): string;
function StrKeepChars(const S: string; const Chars: TSysCharSet): string;
procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []);
function StrReplaceChar(const S: string; const Source, Replace: Char): string;
function StrReplaceChars(const S: string; const Chars: TSysCharSet; Replace: Char): string;
function StrReplaceButChars(const S: string; const Chars: TSysCharSet; Replace: Char): string;
function StrRepeat(const S: string; Count: Integer): string;
function StrRepeatLength(const S: string; L: Integer): string;
function StrReverse(const S: string): string;
procedure StrReverseInPlace(var S: string);
function StrSingleQuote(const S: string): string;
function StrSmartCase(const S: string; Delimiters: TSysCharSet): string;
function StrStringToEscaped(const S: string): string;
function StrStripNonNumberChars(const S: string): string;
function StrToHex(const Source: string): string;
function StrTrimCharLeft(const S: string; C: Char): string;
function StrTrimCharsLeft(const S: string; const Chars: TSysCharSet): string;
function StrTrimCharRight(const S: string; C: Char): string;
function StrTrimCharsRight(const S: string; const Chars: TSysCharSet): string;
function StrTrimQuotes(const S: string): string;
function StrUpper(const S: string): string;
procedure StrUpperInPlace(var S: string);
{$IFNDEF CLR}
procedure StrUpperBuff(S: PChar);
{$ENDIF ~CLR}
{$IFDEF WIN32}
function StrOemToAnsi(const S: string): string;
function StrAnsiToOem(const S: string): string;
{$ENDIF WIN32}
{$IFNDEF CLR}
// String Management
procedure StrAddRef(var S: string);
function StrAllocSize(const S: string): Longint;
procedure StrDecRef(var S: string);
function StrLen(S: PChar): Integer;
function StrLength(const S: string): Longint;
function StrRefCount(const S: string): Longint;
{$ENDIF ~CLR}
procedure StrResetLength(var S: string); overload;
{$IFDEF CLR}
procedure StrResetLength(S: StringBuilder); overload;
{$ENDIF CLR}
// String Search and Replace Routines
function StrCharCount(const S: string; C: Char): Integer;
function StrCharsCount(const S: string; Chars: TSysCharSet): Integer;
function StrStrCount(const S, SubS: string): Integer;
function StrCompare(const S1, S2: string): Integer;
function StrCompareRange(const S1, S2: string; const Index, Count: Integer): Integer;
function StrFillChar(const C: Char; Count: Integer): string;
function StrFind(const Substr, S: string; const Index: Integer = 1): Integer;
function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean;
function StrIndex(const S: string; const List: array of string): Integer;
function StrILastPos(const SubStr, S: string): Integer;
function StrIPos(const SubStr, S: string): Integer;
function StrIsOneOf(const S: string; const List: array of string): Boolean;
function StrLastPos(const SubStr, S: string): Integer;
function StrMatch(const Substr, S: string; const Index: Integer = 1): Integer;
function StrMatches(const Substr, S: string; const Index: Integer = 1): Boolean;
function StrNIPos(const S, SubStr: string; N: Integer): Integer;
function StrNPos(const S, SubStr: string; N: Integer): Integer;
function StrPrefixIndex(const S: string; const Prefixes: array of string): Integer;
function StrSearch(const Substr, S: string; const Index: Integer = 1): Integer;
// String Extraction
function StrAfter(const SubStr, S: string): string;
function StrBefore(const SubStr, S: string): string;
function StrBetween(const S: string; const Start, Stop: Char): string;
function StrChopRight(const S: string; N: Integer): string;
function StrLeft(const S: string; Count: Integer): string;
function StrMid(const S: string; Start, Count: Integer): string;
function StrRestOf(const S: string; N: Integer): string;
function StrRight(const S: string; Count: Integer): string;
// Character Test Routines
function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsAlpha(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsBlank(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsControl(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsDelete(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsDigit(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsLower(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsNumberChar(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsPrintable(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsPunctuation(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsReturn(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsSpace(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsUpper(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF CLR} inline; {$ENDIF}
{$IFNDEF CLR}
function CharType(const C: Char): Word;
{$ENDIF ~CLR}
// Character Transformation Routines
function CharHex(const C: Char): Byte;
function CharLower(const C: Char): Char; {$IFDEF CLR} inline; {$ENDIF}
function CharUpper(const C: Char): Char; {$IFDEF CLR} inline; {$ENDIF}
function CharToggleCase(const C: Char): Char;
// Character Search and Replace
function CharPos(const S: string; const C: Char; const Index: Integer = 1): Integer;
function CharLastPos(const S: string; const C: Char; const Index: Integer = 1): Integer;
function CharIPos(const S: string; C: Char; const Index: Integer = 1 ): Integer;
function CharReplace(var S: string; const Search, Replace: Char): Integer;
{$IFNDEF CLR}
// PCharVector
type
PCharVector = ^PChar;
function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector;
function PCharVectorCount(Source: PCharVector): Integer;
procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector);
procedure FreePCharVector(var Dest: PCharVector);
// MultiSz Routines
type
PMultiSz = PChar;
PWideMultiSz = PWideChar;
function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz;
procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz);
function MultiSzLength(const Source: PMultiSz): Integer;
procedure AllocateMultiSz(var Dest: PMultiSz; Len: Integer);
procedure FreeMultiSz(var Dest: PMultiSz);
function MultiSzDup(const Source: PMultiSz): PMultiSz;
function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz;
procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz);
function WideMultiSzLength(const Source: PWideMultiSz): Integer;
procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: Integer);
procedure FreeWideMultiSz(var Dest: PWideMultiSz);
function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz;
{$ENDIF ~CLR}
// TStrings Manipulation
procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);
procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);
function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string;
procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True );
procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True);
procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True );
function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean;
// Miscellaneous
function BooleanToStr(B: Boolean): string;
function FileToString(const FileName: string): AnsiString;
procedure StringToFile(const FileName: string; const Contents: AnsiString);
function StrToken(var S: string; Separator: Char): string;
procedure StrTokens(const S: string; const List: TStrings);
procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings);
{$IFDEF CLR}
function StrWord(const S: string; var Index: Integer; out Word: string): Boolean;
{$ELSE}
function StrWord(var S: PChar; out Word: string): Boolean;
{$ENDIF CLR}
function StrToFloatSafe(const S: string): Float;
function StrToIntSafe(const S: string): Integer;
procedure StrNormIndex(const StrLen: Integer; var Index: Integer; var Count: Integer); overload;
{$IFDEF CLR}
function ArrayOf(List: TStrings): TDynStringArray; overload;
{$ENDIF CLR}
{$IFDEF COMPILER5} // missing Delphi 5 functions
function TryStrToInt(const S: string; out Value: Integer): Boolean;
function TryStrToInt64(const S: string; out Value: Int64): Boolean;
function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload;
function TryStrToFloat(const S: string; out Value: Double): Boolean; overload;
function TryStrToFloat(const S: string; out Value: Single): Boolean; overload;
function TryStrToCurr(const S: string; out Value: Currency): Boolean;
{$ENDIF COMPILER5}
// Exceptions
type
EJclStringError = EJclError;
implementation
uses
{$IFDEF CLR}
System.Globalization,
{$ENDIF CLR}
{$IFDEF HAS_UNIT_LIBC}
Libc,
{$ENDIF HAS_UNIT_LIBC}
JclLogic, JclResources;
//=== Internal ===============================================================
{$IFNDEF CLR}
type
TAnsiStrRec = packed record
AllocSize: Longint;
RefCount: Longint;
Length: Longint;
end;
const
AnsiStrRecSize = SizeOf(TAnsiStrRec); // size of the string header rec
AnsiCharCount = Ord(High(Char)) + 1; // # of chars in one set
AnsiLoOffset = AnsiCharCount * 0; // offset to lower case chars
AnsiUpOffset = AnsiCharCount * 1; // offset to upper case chars
AnsiReOffset = AnsiCharCount * 2; // offset to reverse case chars
AnsiAlOffset = 12; // offset to AllocSize in StrRec
AnsiRfOffset = 8; // offset to RefCount in StrRec
AnsiLnOffset = 4; // offset to Length in StrRec
AnsiCaseMapSize = AnsiCharCount * 3; // # of chars is a table
var
AnsiCaseMap: array [0..AnsiCaseMapSize - 1] of Char; // case mappings
AnsiCaseMapReady: Boolean = False; // true if case map exists
AnsiCharTypes: array [Char] of Word;
procedure LoadCharTypes;
var
CurrChar: Char;
CurrType: Word;
{$IFDEF CLR}
Category: System.Globalization.UnicodeCategory;
{$ENDIF CLR}
begin
for CurrChar := Low(Char) to High(Char) do
begin
{$IFDEF MSWINDOWS}
GetStringTypeExA(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, SizeOf(Char), CurrType);
{$DEFINE CHAR_TYPES_INITIALIZED}
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
CurrType := 0;
if isupper(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_UPPER;
if islower(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_LOWER;
if isdigit(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_DIGIT;
if isspace(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_SPACE;
if ispunct(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_PUNCT;
if iscntrl(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_CNTRL;
if isblank(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_BLANK;
if isxdigit(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_XDIGIT;
if isalpha(Byte(CurrChar)) <> 0 then
CurrType := CurrType or C1_ALPHA;
{$DEFINE CHAR_TYPES_INITIALIZED}
{$ENDIF LINUX}
AnsiCharTypes[CurrChar] := CurrType;
{$IFNDEF CHAR_TYPES_INITIALIZED}
Implement case map initialization here
{$ENDIF ~CHAR_TYPES_INITIALIZED}
end;
end;
procedure LoadCaseMap;
var
CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char;
begin
if not AnsiCaseMapReady then
begin
for CurrChar := Low(Char) to High(Char) do
begin
{$IFDEF MSWINDOWS}
LoCaseChar := CurrChar;
UpCaseChar := CurrChar;
Windows.CharLowerBuff(@LoCaseChar, 1);
Windows.CharUpperBuff(@UpCaseChar, 1);
{$DEFINE CASE_MAP_INITIALIZED}
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
LoCaseChar := Char(tolower(Byte(CurrChar)));
UpCaseChar := Char(toupper(Byte(CurrChar)));
{$DEFINE CASE_MAP_INITIALIZED}
{$ENDIF LINUX}
{$IFNDEF CASE_MAP_INITIALIZED}
Implement case map initialization here
{$ENDIF ~CASE_MAP_INITIALIZED}
if CharIsUpper(CurrChar) then
ReCaseChar := LoCaseChar
else
if CharIsLower(CurrChar) then
ReCaseChar := UpCaseChar
else
ReCaseChar := CurrChar;
AnsiCaseMap[Ord(CurrChar) + AnsiLoOffset] := LoCaseChar;
AnsiCaseMap[Ord(CurrChar) + AnsiUpOffset] := UpCaseChar;
AnsiCaseMap[Ord(CurrChar) + AnsiReOffset] := ReCaseChar;
end;
AnsiCaseMapReady := True;
end;
end;
{$ENDIF ~CLR}
// Uppercases or Lowercases a give string depending on the
// passed offset. (UpOffset or LoOffset)
{$IFDEF CLR}
const
AnsiLoOffset = 0;
AnsiUpOffset = 1;
procedure StrCase(var Str: string; const Offset: Integer);
begin
if Offset = AnsiUpOffset then
Str := Str.ToUpper
else
Str := Str.ToLower;
end;
{$ELSE}
procedure StrCase(var Str: string; const Offset: Integer); register; assembler;
asm
// make sure that the string is not null
TEST EAX, EAX
JZ @@StrIsNull
// create unique string if this one is ref-counted
PUSH EDX
CALL UniqueString
POP EDX
// make sure that the new string is not null
TEST EAX, EAX
JZ @@StrIsNull
// get the length, and prepare the counter
MOV ECX, [EAX - AnsiStrRecSize].TAnsiStrRec.Length
DEC ECX
JS @@StrIsNull
// ebx will hold the case map, esi pointer to Str
PUSH EBX
PUSH ESI
PUSH EDI
// load case map and prepare variables }
{$IFDEF PIC}
LEA EBX, [EBX][AnsiCaseMap + EDX]
{$ELSE}
LEA EBX, [AnsiCaseMap + EDX]
{$ENDIF PIC}
MOV ESI, EAX
XOR EDX, EDX
XOR EAX, EAX
@@NextChar:
// get current char from the string
MOV DL, [ESI]
// get corresponding char from the case map
MOV AL, [EBX + EDX]
// store it back in the string
MOV [ESI], AL
// update the loop counter and check the end of stirng
DEC ECX
JL @@Done
// do the same thing with next 3 chars
MOV DL, [ESI + 1]
MOV AL, [EBX + EDX]
MOV [ESI + 1], AL
DEC ECX
JL @@Done
MOV DL, [ESI + 2]
MOV AL, [EBX+EDX]
MOV [ESI + 2], AL
DEC ECX
JL @@Done
MOV DL, [ESI + 3]
MOV AL, [EBX + EDX]
MOV [ESI + 3], AL
// point string to next 4 chars
ADD ESI, 4
// update the loop counter and check the end of stirng
DEC ECX
JGE @@NextChar
@@Done:
POP EDI
POP ESI
POP EBX
@@StrIsNull:
end;
{$ENDIF CLR}
{$IFNDEF CLR}
// Internal utility function
// Uppercases or Lowercases a give null terminated string depending on the
// passed offset. (UpOffset or LoOffset)
procedure StrCaseBuff(S: PChar; const Offset: Integer); register; assembler;
asm
// make sure the string is not null
TEST EAX, EAX
JZ @@StrIsNull
// ebx will hold the case map, esi pointer to Str
PUSH EBX
PUSH ESI
// load case map and prepare variables
{$IFDEF PIC}
LEA EBX, [EBX][AnsiCaseMap + EDX]
{$ELSE}
LEA EBX, [AnsiCaseMap + EDX]
{$ENDIF PIC}
MOV ESI, EAX
XOR EDX, EDX
XOR EAX, EAX
@@NextChar:
// get current char from the string
MOV DL, [ESI]
// check for null char
TEST DL, DL
JZ @@Done
// get corresponding char from the case map
MOV AL, [EBX + EDX]
// store it back in the string
MOV [ESI], AL
// do the same thing with next 3 chars
MOV DL, [ESI + 1]
TEST DL, DL
JZ @@Done
MOV AL, [EBX+EDX]
MOV [ESI + 1], AL
MOV DL, [ESI + 2]
TEST DL, DL
JZ @@Done
MOV AL, [EBX+EDX]
MOV [ESI + 2], AL
MOV DL, [ESI + 3]
TEST DL, DL
JZ @@Done
MOV AL, [EBX+EDX]
MOV [ESI + 3], AL
// point string to next 4 chars
ADD ESI, 4
JMP @@NextChar
@@Done:
POP ESI
POP EBX
@@StrIsNull:
end;
function StrEndW(Str: PWideChar): PWideChar; assembler;
// returns a pointer to the end of a null terminated string
// stolen from JclUnicode
asm
MOV EDX, EDI
MOV EDI, EAX
MOV ECX, 0FFFFFFFFH
XOR AX, AX
REPNE SCASW
LEA EAX, [EDI - 2]
MOV EDI, EDX
end;
{$ENDIF ~CLR}
// String Test Routines
function StrIsAlpha(const S: string): Boolean;
var
I: Integer;
begin
Result := S <> '';
for I := 1 to Length(S) do
begin
if not CharIsAlpha(S[I]) then
begin
Result := False;
Exit;
end;
end;
end;
function StrIsAlphaNum(const S: string): Boolean;
var
I: Integer;
begin
Result := S <> '';
for I := 1 to Length(S) do
begin
if not CharIsAlphaNum(S[I]) then
begin
Result := False;
Exit;
end;
end;
end;
function StrConsistsofNumberChars(const S: string): Boolean;
var
I: Integer;
begin
Result := S <> '';
for I := 1 to Length(S) do
begin
if not CharIsNumberChar(S[I]) then
begin
Result := False;
Exit;
end;
end;
end;
function StrContainsChars(const S: string; Chars: TSysCharSet; CheckAll: Boolean): Boolean;
var
I: Integer;
C: Char;
begin
Result := Chars = [];
if not Result then
begin
if CheckAll then
begin
for I := 1 to Length(S) do
begin
C := S[I];
if C in Chars then
begin
Chars := Chars - [AnsiChar(C)];
if Chars = [] then
Break;
end;
end;
Result := (Chars = []);
end
else
begin
for I := 1 to Length(S) do
if S[I] in Chars then
begin
Result := True;
Break;
end;
end;
end;
end;
function StrIsAlphaNumUnderscore(const S: string): Boolean;
var
I: Integer;
C: Char;
begin
for i := 1 to Length(s) do
begin
C := S[I];
if not (CharIsAlphaNum(C) or (C = '_')) then
begin
Result := False;
Exit;
end;
end;
Result := True and (Length(S) > 0);
end;
function StrIsDigit(const S: string): Boolean;
var
I: Integer;
begin
Result := S <> '';
for I := 1 to Length(S) do
begin
if not CharIsDigit(S[I]) then
begin
Result := False;
Exit;
end;
end;
end;
function StrIsSubset(const S: string; const ValidChars: TSysCharSet): Boolean;
var
I: Integer;
begin
for I := 1 to Length(S) do
begin
if not (S[I] in ValidChars) then
begin
Result := False;
Exit;
end;
end;
Result := True and (Length(S) > 0);
end;
function StrSame(const S1, S2: string): Boolean;
begin
Result := StrCompare(S1, S2) = 0;
end;
//=== String Transformation Routines =========================================
function StrCenter(const S: string; L: Integer; C: Char = ' '): string;
begin
if Length(S) < L then
begin
Result := StringOfChar(C, (L - Length(S)) div 2) + S;
Result := Result + StringOfChar(C, L - Length(Result));
end
else
Result := S;
end;
function StrCharPosLower(const S: string; CharPos: Integer): string;
begin
Result := S;
if (CharPos > 0) and (CharPos <= Length(S)) then
Result[CharPos] := CharLower(Result[CharPos]);
end;
function StrCharPosUpper(const S: string; CharPos: Integer): string;
begin
Result := S;
if (CharPos > 0) and (CharPos <= Length(S)) then
Result[CharPos] := CharUpper(Result[CharPos]);
end;
function StrDoubleQuote(const S: string): string;
begin
Result := AnsiDoubleQuote + S + AnsiDoubleQuote;
end;
function StrEnsureNoPrefix(const Prefix, Text: string): string;
var
PrefixLen : Integer;
begin
PrefixLen := Length(Prefix);
if Copy(Text, 1, PrefixLen) = Prefix then
Result := Copy(Text, PrefixLen + 1, Length(Text))
else
Result := Text;
end;
function StrEnsureNoSuffix(const Suffix, Text: string): string;
var
SuffixLen : Integer;
StrLength : Integer;
begin
SuffixLen := Length(Suffix);
StrLength := Length(Text);
if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then
Result := Copy(Text, 1, StrLength - SuffixLen)
else
Result := Text;
end;
function StrEnsurePrefix(const Prefix, Text: string): string;
var
PrefixLen: Integer;
begin
PrefixLen := Length(Prefix);
if Copy(Text, 1, PrefixLen) = Prefix then
Result := Text
else
Result := Prefix + Text;
end;
function StrEnsureSuffix(const Suffix, Text: string): string;
var
SuffixLen: Integer;
begin
SuffixLen := Length(Suffix);
if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then
Result := Text
else
Result := Text + Suffix;
end;
function StrEscapedToString(const S: string): string;
var
I, Len, N, Val: Integer;
procedure HandleHexEscapeSeq;
const
HexDigits = string('0123456789abcdefABCDEF');
begin
N := Pos(S[I + 1], HexDigits) - 1;
if N < 0 then
// '\x' without hex digit following is not escape sequence
Result := Result + '\x'
else
begin
Inc(I); // Jump over x
if N >= 16 then
N := N - 6;
Val := N;
// Same for second digit
if I < Len then
begin
N := Pos(S[I + 1], HexDigits) - 1;
if N >= 0 then
begin
Inc(I); // Jump over first digit
if N >= 16 then
N := N - 6;
Val := Val * 16 + N;
end;
end;
if val > 255 then
{$IFDEF CLR}
raise EJclStringError.Create(RsNumericConstantTooLarge);
{$ELSE}
raise EJclStringError.CreateRes(@RsNumericConstantTooLarge);
{$ENDIF CLR}
Result := Result + Chr(Val);
end;
end;
procedure HandleOctEscapeSeq;
const
OctDigits = string('01234567');
begin
// first digit
Val := Pos(S[I], OctDigits) - 1;
if I < Len then
begin
N := Pos(S[I + 1], OctDigits) - 1;
if N >= 0 then
begin
Inc(I);
Val := Val * 8 + N;
end;
if I < Len then
begin
N := Pos(S[I + 1], OctDigits) - 1;
if N >= 0 then
begin
Inc(I);
Val := Val * 8 + N;
end;
end;
end;
if val > 255 then
{$IFDEF CLR}
raise EJclStringError.Create(RsNumericConstantTooLarge);
{$ELSE}
raise EJclStringError.CreateRes(@RsNumericConstantTooLarge);
{$ENDIF CLR}
Result := Result + Chr(Val);
end;
begin
Result := '';
I := 1;
Len := Length(S);
while I <= Len do
begin
if not ((S[I] = '\') and (I < Len)) then
Result := Result + S[I]
else
begin
Inc(I); // Jump over escape character
case S[I] of
'a':
Result := Result + AnsiBell;
'b':
Result := Result + AnsiBackspace;
'f':
Result := Result + AnsiFormFeed;
'n':
Result := Result + AnsiLineFeed;
'r':
Result := Result + AnsiCarriageReturn;
't':
Result := Result + AnsiTab;
'v':
Result := Result + AnsiVerticalTab;
'\':
Result := Result + '\';
'"':
Result := Result + '"';
'''':
Result := Result + ''''; // Optionally escaped
'?':
Result := Result + '?'; // Optionally escaped
'x':
if I < Len then
// Start of hex escape sequence
HandleHexEscapeSeq
else
// '\x' at end of string is not escape sequence
Result := Result + '\x';
'0'..'7':
// start of octal escape sequence
HandleOctEscapeSeq;
else
// no escape sequence
Result := Result + '\' + S[I];
end;
end;
Inc(I);
end;
end;
function StrLower(const S: string): string;
begin
Result := S;
StrLowerInPlace(Result);
end;
procedure StrLowerInPlace(var S: string);
{$IFDEF PIC}
begin
StrCase(S, AnsiLoOffset);
end;
{$ELSE}
assembler;
asm
// StrCase(S, AnsiLoOffset)
XOR EDX, EDX // MOV EDX, LoOffset
JMP StrCase
end;
{$ENDIF PIC}
{$IFNDEF CLR}
procedure StrLowerBuff(S: PChar);
{$IFDEF PIC}
begin
StrCaseBuff(S, AnsiLoOffset);
end;
{$ELSE}
assembler;
asm
// StrCaseBuff(S, LoOffset)
XOR EDX, EDX // MOV EDX, LoOffset
JMP StrCaseBuff
end;
{$ENDIF PIC}
{$ENDIF ~CLR}
{$IFDEF CLR}
procedure MoveString(const Source: string; SrcIndex: Integer;
var Dest: string; DstIndex, Count: Integer);
begin
Dec(SrcIndex);
Dec(DstIndex);
Dest := Dest.Remove(DstIndex, Count).Insert(DstIndex, Source.Substring(SrcIndex, Count));
end;
{$ENDIF CLR}
procedure StrMove(var Dest: string; const Source: string;
const ToIndex, FromIndex, Count: Integer);
begin
// Check strings
if (Source = '') or (Length(Dest) = 0) then
Exit;
// Check FromIndex
if (FromIndex <= 0) or (FromIndex > Length(Source)) or
(ToIndex <= 0) or (ToIndex > Length(Dest)) or
((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then
{ TODO : Is failure without notice the proper thing to do here? }
Exit;
// Move
{$IFDEF CLR}
MoveString(Source, FromIndex, Dest, ToIndex, Count);
{$ELSE}
Move(Source[FromIndex], Dest[ToIndex], Count);
{$ENDIF CLR}
end;
function StrPadLeft(const S: string; Len: Integer; C: Char): string;
var
L: Integer;
begin
L := Length(S);
if L < Len then
Result := StringOfChar(C, Len - L) + S
else
Result := S;
end;
function StrPadRight(const S: string; Len: Integer; C: Char): string;
var
L: Integer;
begin
L := Length(S);
if L < Len then
Result := S + StringOfChar(C, Len - L)
else
Result := S;
end;
function StrProper(const S: string): string;
begin
{$IFDEF CLR}
Result := S.ToLower;
{$ELSE}
Result := StrLower(S);
{$ENDIF CLR}
if Result <> '' then
Result[1] := UpCase(Result[1]);
end;
{$IFNDEF CLR}
procedure StrProperBuff(S: PChar);
begin
if (S <> nil) and (S^ <> #0) then
begin
StrLowerBuff(S);
S^ := CharUpper(S^);
end;
end;
{$ENDIF ~CLR}
function StrQuote(const S: string; C: Char): string;
var
L: Integer;
begin
L := Length(S);
Result := S;
if L > 0 then
begin
if Result[1] <> C then
begin
Result := C + Result;
Inc(L);
end;
if Result[L] <> C then
Result := Result + C;
end;
end;
function StrRemoveChars(const S: string; const Chars: TSysCharSet): string;
{$IFDEF CLR}
var
I: Integer;
sb: StringBuilder;
begin
sb := StringBuilder.Create(Length(S));
for I := 0 to S.Length - 1 do
if not (AnsiChar(S[I]) in Chars) then
sb.Append(S[I]);
Result := sb.ToString();
end;
{$ELSE}
var
Source, Dest: PChar;
Len, Index: Integer;
begin
Len := Length(S);
SetLength(Result, Len);
UniqueString(Result);
Source := PChar(S);
Dest := PChar(Result);
for Index := 0 to Len-1 do
begin
if not (Source^ in Chars) then
begin
Dest^ := Source^;
Inc(Dest,SizeOf(Char));
end;
Inc(Source,SizeOf(Char));
end;
SetLength(Result, (Longint(Dest) - Longint(PChar(Result))) div SizeOf(Char));
end;
{$ENDIF CLR}
function StrKeepChars(const S: string; const Chars: TSysCharSet): string;
{$IFDEF CLR}
var
I: Integer;
sb: StringBuilder;
begin
sb := StringBuilder.Create(Length(S));
for I := 0 to S.Length - 1 do
if AnsiChar(S[I]) in Chars then
sb.Append(S[I]);
Result := sb.ToString();
end;
{$ELSE}
var
Source, Dest: PChar;
Len, Index: Integer;
begin
Len := Length(S);
SetLength(Result, Len);
UniqueString(Result);
Source := PChar(S);
Dest := PChar(Result);
for Index := 0 to Len-1 do
begin
if Source^ in Chars then
begin
Dest^ := Source^;
Inc(Dest,SizeOf(Char));
end;
Inc(Source,SizeOf(Char));
end;
SetLength(Result, (Longint(Dest) - Longint(PChar(Result))) div SizeOf(Char));
end;
{$ENDIF CLR}
function StrRepeat(const S: string; Count: Integer): string;
{$IFDEF CLR}
var
I, Len: Integer;
sb: StringBuilder;
begin
Len := Length(S);
if Len * Count > 0 then
begin
sb := StringBuilder.Create(Len * Count);
for I := Count - 1 downto 0 do
sb.Append(S);
Result := sb.ToString();
end
else
Result := '';
end;
{$ELSE}
var
Len, Index: Integer;
Dest, Source: PChar;
begin
Len := Length(S);
SetLength(Result, Count * Len);
Dest := PChar(Result);
Source := PChar(S);
if Dest <> nil then
for Index := 0 to Count - 1 do
begin
Move(Source^, Dest^, Len*SizeOf(Char));
Inc(Dest,Len*SizeOf(Char));
end;
end;
{$ENDIF CLR}
function StrRepeatLength(const S: string; L: Integer): string;
{$IFDEF CLR}
var
Count: Integer;
LenS, Index: Integer;
begin
Result := '';
LenS := Length(S);
if (LenS > 0) and (S <> '') then
begin
Count := L div LenS;
if Count * LenS < L then
Inc(Count);
SetLength(Result, Count * LenS);
Index := 1;
while Count > 0 do
begin
MoveString(S, 1, Result, Index, LenS);
Inc(Index, LenS);
Dec(Count);
end;
if Length(S) > L then
SetLength(Result, L);
end;
end;
{$ELSE}
var
Len: Integer;
Dest: PChar;
begin
Result := '';
Len := Length(S);
if (Len > 0) and (S <> '') then
begin
SetLength(Result,L);
Dest := PChar(Result);
while (L > 0) do
begin
Move(S[1],Dest^,Min(L,Len)*SizeOf(Char));
Inc(Dest,Len);
Dec(L,Len);
end;
end;
end;
{$ENDIF CLR}
procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags);
{$IFDEF CLR}
begin
S := StringReplace(S, Search, Replace, Flags); // !!! Convertion to System.String
end;
{$ELSE}
var
SearchStr: string;
ResultStr: string; { result string }
SourcePtr: PChar; { pointer into S of character under examination }
SourceMatchPtr: PChar; { pointers into S and Search when first character has }
SearchMatchPtr: PChar; { been matched and we're probing for a complete match }
ResultPtr: PChar; { pointer into Result of character being written }
ResultIndex,
SearchLength, { length of search string }
ReplaceLength, { length of replace string }
BufferLength, { length of temporary result buffer }
ResultLength: Integer; { length of result string }
C: Char; { first character of search string }
IgnoreCase: Boolean;
begin
if Search = '' then
if S = '' then
begin
S := Replace;
Exit;
end
else
raise EJclStringError.CreateRes(@RsBlankSearchString);
if S <> '' then
begin
IgnoreCase := rfIgnoreCase in Flags;
if IgnoreCase then
SearchStr := AnsiUpperCase(Search)
else
SearchStr := Search;
{ avoid having to call Length() within the loop }
SearchLength := Length(Search);
ReplaceLength := Length(Replace);
ResultLength := Length(S);
BufferLength := ResultLength;
SetLength(ResultStr, BufferLength);
{ get pointers to begin of source and result }
ResultPtr := PChar(ResultStr);
SourcePtr := PChar(S);
C := SearchStr[1];
{ while we haven't reached the end of the string }
while True do
begin
{ copy characters until we find the first character of the search string }
if IgnoreCase then
while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do
begin
ResultPtr^ := SourcePtr^;
Inc(ResultPtr);
Inc(SourcePtr);
end
else
while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do
begin
ResultPtr^ := SourcePtr^;
Inc(ResultPtr);
Inc(SourcePtr);
end;
{ did we find that first character or did we hit the end of the string? }
if SourcePtr^ = #0 then
Break
else
begin
{ continue comparing, +1 because first character was matched already }
SourceMatchPtr := SourcePtr + 1;
SearchMatchPtr := PChar(SearchStr) + 1;
if IgnoreCase then
while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do
begin
Inc(SourceMatchPtr);
Inc(SearchMatchPtr);
end
else
while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do
begin
Inc(SourceMatchPtr);
Inc(SearchMatchPtr);
end;
{ did we find a complete match? }
if SearchMatchPtr^ = #0 then
begin
// keep track of result length
Inc(ResultLength, ReplaceLength - SearchLength);
if ReplaceLength > 0 then
begin
// increase buffer size if required
if ResultLength > BufferLength then
begin
BufferLength := ResultLength * 2;
ResultIndex := ResultPtr - PChar(ResultStr) + 1;
SetLength(ResultStr, BufferLength);
ResultPtr := @ResultStr[ResultIndex];
end;
{ append replace to result and move past the search string in source }
Move((@Replace[1])^, ResultPtr^, ReplaceLength);
end;
Inc(SourcePtr, SearchLength);
Inc(ResultPtr, ReplaceLength);
{ replace all instances or just one? }
if not (rfReplaceAll in Flags) then
begin
{ just one, copy until end of source and break out of loop }
while SourcePtr^ <> #0 do
begin
ResultPtr^ := SourcePtr^;
Inc(ResultPtr);
Inc(SourcePtr);
end;
Break;
end;
end
else
begin
{ copy current character and start over with the next }
ResultPtr^ := SourcePtr^;
Inc(ResultPtr);
Inc(SourcePtr);
end;
end;
end;
{ set result length and copy result into S }
SetLength(ResultStr, ResultLength);
S := ResultStr;
end;
end;
{$ENDIF CLR}
function StrReplaceChar(const S: string; const Source, Replace: Char): string;
{$IFNDEF CLR}
var
I: Integer;
{$ENDIF ~CLR}
begin
{$IFDEF CLR}
Result := S.Replace(Source, Replace);
{$ELSE}
Result := S;
for I := 1 to Length(S) do
if Result[I] = Source then
Result[I] := Replace;
{$ENDIF CLR}
end;
function StrReplaceChars(const S: string; const Chars: TSysCharSet; Replace: Char): string;
var
I: Integer;
{$IFDEF CLR}
sb: StringBuilder;
{$ENDIF CLR}
begin
{$IFDEF CLR}
sb := StringBuilder.Create(S);
for I := 0 to sb.Length - 1 do
if AnsiChar(sb[I]) in Chars then
sb[I] := Replace;
Result := sb.ToString();
{$ELSE}
Result := S;
for I := 1 to Length(S) do
if Result[I] in Chars then
Result[I] := Replace;
{$ENDIF CLR}
end;
function StrReplaceButChars(const S: string; const Chars: TSysCharSet;
Replace: Char): string;
var
I: Integer;
{$IFDEF CLR}
sb: StringBuilder;
{$ENDIF CLR}
begin
{$IFDEF CLR}
sb := StringBuilder.Create(S);
for I := 0 to sb.Length - 1 do
if not (AnsiChar(sb[I]) in Chars) then
sb[I] := Replace;
Result := sb.ToString();
{$ELSE}
Result := S;
for I := 1 to Length(S) do
if not (Result[I] in Chars) then
Result[I] := Replace;
{$ENDIF CLR}
end;
function StrReverse(const S: string): string;
begin
Result := S;
StrReverseInplace(Result);
end;
procedure StrReverseInPlace(var S: string);
{$IFDEF CLR}
var
I, LenS: Integer;
sb: StringBuilder;
begin
LenS := Length(S);
sb := StringBuilder.Create(LenS);
sb.Length := LenS;
for I := 0 to LenS - 1 do
sb[I] := S[LenS - I - 1];
S := sb.ToString();
end;
{$ELSE}
var
P1, P2: PChar;
C: Char;
begin
UniqueString(S);
P1 := PChar(S);
P2 := P1 + SizeOf(Char) * (Length(S) - 1);
while P1 < P2 do
begin
C := P1^;
P1^ := P2^;
P2^ := C;
Inc(P1);
Dec(P2);
end;
end;
{$ENDIF CLR}
function StrSingleQuote(const S: string): string;
begin
Result := AnsiSingleQuote + S + AnsiSingleQuote;
end;
function StrSmartCase(const S: string; Delimiters: TSysCharSet): string;
var
{$IFDEF CLR}
Index: Integer;
LenS: Integer;
sb: StringBuilder;
{$ELSE}
Source, Dest: PChar;
Index, Len: Integer;
{$ENDIF CLR}
begin
Result := '';
if Delimiters = [] then
Include(Delimiters, AnsiSpace);
if S <> '' then
begin
Result := S;
{$IFDEF CLR}
sb := StringBuilder.Create(S);
LenS := Length(S);
Index := 0;
while Index < LenS do
begin
if (AnsiChar(sb[Index]) in Delimiters) and (Index + 1 < LenS) and
not (AnsiChar(sb[Index + 1]) in Delimiters) then
sb[Index + 1] := CharUpper(sb[Index + 1]);
Inc(Index);
end;
sb[0] := CharUpper(sb[0]);
Result := sb.ToString();
{$ELSE}
UniqueString(Result);
Len := Length(S);
Source := PChar(S);
Dest := PChar(Result);
Inc(Dest);
for Index := 2 to Len do
begin
if (Source^ in Delimiters) and not (Dest^ in Delimiters) then
Dest^ := CharUpper(Dest^);
Inc(Dest);
Inc(Source);
end;
Result[1] := CharUpper(Result[1]);
{$ENDIF CLR}
end;
end;
function StrStringToEscaped(const S: string): string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(S) do
begin
case S[I] of
AnsiBackspace:
Result := Result + '\b';
AnsiBell:
Result := Result + '\a';
AnsiCarriageReturn:
Result := Result + '\r';
AnsiFormFeed:
Result := Result + '\f';
AnsiLineFeed:
Result := Result + '\n';
AnsiTab:
Result := Result + '\t';
AnsiVerticalTab:
Result := Result + '\v';
'\':
Result := Result + '\\';
'"':
Result := Result + '\"';
else
// Characters < ' ' are escaped with hex sequence
if S[I] < #32 then
Result := Result + Format('\x%.2x',[Integer(S[I])])
else
Result := Result + S[I];
end;
end;
end;
function StrStripNonNumberChars(const S: string): string;
var
I: Integer;
C: Char;
begin
Result := '';
for I := 1 to Length(S) do
begin
C := S[I];
if CharIsNumberChar(C) then
Result := Result + C;
end;
end;
function StrToHex(const Source: string): string;
var
Index: Integer;
C, L, N: Integer;
BL, BH: Byte;
S: string;
{$IFDEF CLR}
sb: StringBuilder;
{$ENDIF CLR}
begin
{$IFDEF CLR}
sb := StringBuilder.Create;
{$ELSE}
Result := '';
{$ENDIF CLR}
if Source <> '' then
begin
S := Source;
L := Length(S);
if Odd(L) then
begin
S := '0' + S;
Inc(L);
end;
Index := 1;
{$IFDEF CLR}
sb.Length := L div 2;
{$ELSE}
SetLength(Result, L div 2);
{$ENDIF CLR}
C := 1;
N := 1;
while C <= L do
begin
BH := CharHex(S[Index]);
Inc(Index);
BL := CharHex(S[Index]);
Inc(Index);
Inc(C, 2);
if (BH = $FF) or (BL = $FF) then
begin
Result := '';
Exit;
end;
{$IFDEF CLR}
sb[N] :=
{$ELSE}
Result[N] :=
{$ENDIF CLR}
Char((BH shl 4) + BL);
Inc(N);
end;
end;
{$IFDEF CLR}
Result := sb.ToString();
{$ENDIF CLR}
end;
function StrTrimCharLeft(const S: string; C: Char): string;
var
I, L: Integer;
begin
I := 1;
L := Length(S);
while (I <= L) and (S[I] = C) do Inc(I);
Result := Copy(S, I, L - I + 1);
end;
function StrTrimCharsLeft(const S: string; const Chars: TSysCharSet): string;
var
I, L: Integer;
begin
I := 1;
L := Length(S);
while (I <= L) and (S[I] in Chars) do Inc(I);
Result := Copy(S, I, L - I + 1);
end;
function StrTrimCharsRight(const S: string; const Chars: TSysCharSet): string;
var
I: Integer;
begin
I := Length(S);
while (I >= 1) and (S[I] in Chars) do Dec(I);
Result := Copy(S, 1, I);
end;
function StrTrimCharRight(const S: string; C: Char): string;
var
I: Integer;
begin
I := Length(S);
while (I >= 1) and (S[I] = C) do Dec(I);
Result := Copy(S, 1, I);
end;
function StrTrimQuotes(const S: string): string;
var
First, Last: Char;
L: Integer;
begin
L := Length(S);
if L > 1 then
begin
First := S[1];
Last := S[L];
if (First = Last) and ((First = AnsiSingleQuote) or (First = AnsiDoubleQuote)) then
Result := Copy(S, 2, L - 2)
else
Result := S;
end
else
Result := S;
end;
function StrUpper(const S: string): string;
begin
Result := S;
StrUpperInPlace(Result);
end;
procedure StrUpperInPlace(var S: string);
{$IFDEF PIC}
begin
StrCase(S, AnsiUpOffset);
end;
{$ELSE}
asm
// StrCase(Str, AnsiUpOffset)
MOV EDX, AnsiUpOffset
JMP StrCase
end;
{$ENDIF PIC}
{$IFNDEF CLR}
procedure StrUpperBuff(S: PChar);
{$IFDEF PIC}
begin
StrCaseBuff(S, AnsiUpOffset);
end;
{$ELSE}
asm
// StrCaseBuff(S, UpOffset)
MOV EDX, AnsiUpOffset
JMP StrCaseBuff
end;
{$ENDIF PIC}
{$ENDIF ~CLR}
{$IFDEF WIN32}
function StrOemToAnsi(const S: string): string;
begin
SetLength(Result, Length(S));
if S <> '' then
OemToAnsiBuff(@S[1], @Result[1], Length(S));
end;
{$ENDIF WIN32}
{$IFDEF WIN32}
function StrAnsiToOem(const S: string): string;
begin
SetLength(Result, Length(S));
if S <> '' then
AnsiToOemBuff(@S[1], @Result[1], Length(S));
end;
{$ENDIF WIN32}
{$IFNDEF CLR}
//=== String Management ======================================================
procedure StrAddRef(var S: string);
var
Foo: string;
begin
if StrRefCount(S) = -1 then
UniqueString(S)
else
begin
Foo := S;
Pointer(Foo) := nil;
end;
end;
function StrAllocSize(const S: string): Longint;
var
P: Pointer;
begin
Result := 0;
if Pointer(S) <> nil then
begin
P := Pointer(Integer(Pointer(S)) - AnsiRfOffset);
if Integer(P^) <> -1 then
begin
P := Pointer(Integer(Pointer(S)) - AnsiAlOffset);
Result := Integer(P^);
end;
end;
end;
procedure StrDecRef(var S: string);
var
Foo: string;
begin
case StrRefCount(S) of
-1, 0: { nothing } ;
1:
begin
Finalize(S);
Pointer(S) := nil;
end;
else
Pointer(Foo) := Pointer(S);
end;
end;
function StrLen(S: PChar): Integer; assembler;
asm
TEST EAX, EAX
JZ @@EXIT
PUSH EBX
MOV EDX, EAX // save pointer
@L1: MOV EBX, [EAX] // read 4 bytes
ADD EAX, 4 // increment pointer
LEA ECX, [EBX-$01010101] // subtract 1 from each byte
NOT EBX // invert all bytes
AND ECX, EBX // and these two
AND ECX, $80808080 // test all sign bits
JZ @L1 // no zero bytes, continue loop
TEST ECX, $00008080 // test first two bytes
JZ @L2
SHL ECX, 16 // not in the first 2 bytes
SUB EAX, 2
@L2: SHL ECX, 9 // use carry flag to avoid a branch
SBB EAX, EDX // compute length
POP EBX
JZ @@EXIT // Az: SBB sets zero flag
DEC EAX // do not include null terminator
@@EXIT:
end;
function StrLength(const S: string): Longint;
var
P: Pointer;
begin
Result := 0;
if Pointer(S) <> nil then
begin
P := Pointer(Integer(Pointer(S)) - AnsiLnOffset);
Result := Integer(P^) and (not $80000000 shr 1);
end;
end;
function StrRefCount(const S: string): Longint;
var
P: Pointer;
begin
Result := 0;
if Pointer(S) <> nil then
begin
P := Pointer(Integer(Pointer(S)) - AnsiRfOffset);
Result := Integer(P^);
end;
end;
{$ENDIF ~CLR}
procedure StrResetLength(var S: string);
{$IFDEF CLR}
var
I: Integer;
{$ENDIF CLR}
begin
{$IFDEF CLR}
for I := 1 to Length(S) do
if S[I] = #0 then
begin
SetLength(S, I);
Exit;
end;
{$ELSE}
SetLength(S, StrLen(PChar(S)));
{$ENDIF CLR}
end;
{$IFDEF CLR}
procedure StrResetLength(S: StringBuilder);
var
I: Integer;
begin
for I := 0 to S.Length - 1 do
if S[I] = #0 then
begin
S.Length := I + 1;
Exit;
end;
end;
{$ENDIF CLR}
//=== String Search and Replace Routines =====================================
function StrCharCount(const S: string; C: Char): Integer;
var
I: Integer;
begin
Result := 0;
for I := 1 to Length(S) do
if S[I] = C then
Inc(Result);
end;
function StrCharsCount(const S: string; Chars: TSysCharSet): Integer;
var
I: Integer;
begin
Result := 0;
for I := 1 to Length(S) do
if S[I] in Chars then
Inc(Result);
end;
function StrStrCount(const S, SubS: string): Integer;
var
I: Integer;
begin
Result := 0;
if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then
Exit;
if Length(SubS) = 1 then
begin
Result := StrCharCount(S, SubS[1]);
Exit;
end;
I := StrSearch(SubS, S, 1);
if I > 0 then
Inc(Result);
while (I > 0) and (Length(S) > I+Length(SubS)) do
begin
I := StrSearch(SubS, S, I+1);
if I > 0 then
Inc(Result);
end
end;
{$IFDEF CLR}
function StrCompare(const S1, S2: string): Integer;
begin
Result := S1.CompareTo(S2);
end;
{$ELSE}
{$IFDEF PIC}
function _StrCompare(const S1, S2: string): Integer; forward;
function StrCompare(const S1, S2: string): Integer;
begin
Result := _StrCompare(S1, S2);
end;
function _StrCompare(const S1, S2: string): Integer; assembler;
{$ELSE}
function StrCompare(const S1, S2: string): Integer; assembler;
{$ENDIF PIC}
asm
// check if pointers are equal
CMP EAX, EDX
JE @@Equal
// if S1 is nil return - Length(S2)
TEST EAX, EAX
JZ @@Str1Null
// if S2 is nil return Length(S1)
TEST EDX, EDX
JZ @@Str2Null
// EBX will hold case map, ESI S1, EDI S2
PUSH EBX
PUSH ESI
PUSH EDI
// move string pointers
MOV ESI, EAX
MOV EDI, EDX
// get the length of strings
MOV EAX, [ESI-AnsiStrRecSize].TAnsiStrRec.Length
MOV EDX, [EDI-AnsiStrRecSize].TAnsiStrRec.Length
// exit if Length(S1) <> Length(S2)
CMP EAX, EDX
JNE @@MissMatch
// check the length just in case
DEC EDX
JS @@InvalidStr
DEC EAX
JS @@InvalidStr
// load case map
LEA EBX, AnsiCaseMap
// make ECX our loop counter
MOV ECX, EAX
// clear working regs
XOR EAX, EAX
XOR EDX, EDX
// get last chars
MOV AL, [ESI+ECX]
MOV DL, [EDI+ECX]
// lower case them
MOV AL, [EBX+EAX]
MOV DL, [EBX+EDX]
// compare them
CMP AL, DL
JNE @@MissMatch
// if there was only 1 char then exit
JECXZ @@Match
@@NextChar:
// case sensitive compare of strings
REPE CMPSB
JE @@Match
// if there was a missmatch try case insensitive compare, get the chars
MOV AL, [ESI-1]
MOV DL, [EDI-1]
// lowercase and compare them, if equal then continue
MOV AL, [EBX+EAX]
MOV DL, [EBX+EDX]
CMP AL, DL
JE @@NextChar
// if we make it here then strings don't match, return the difference
@@MissMatch:
SUB EAX, EDX
POP EDI
POP ESI
POP EBX
RET
@@Match:
// match, return 0
XOR EAX, EAX
POP EDI
POP ESI
POP EBX
RET
@@InvalidStr:
XOR EAX, EAX
DEC EAX
POP EDI
POP ESI
POP EBX
RET
@@Str1Null:
// return = - Length(Str2);
MOV EDX, [EDX-AnsiStrRecSize].TAnsiStrRec.Length
SUB EAX, EDX
RET
@@Str2Null:
// return = Length(Str2);
MOV EAX, [EAX-AnsiStrRecSize].TAnsiStrRec.Length
RET
@@Equal:
XOR EAX, EAX
end;
{$ENDIF CLR}
{$IFDEF CLR}
function StrCompareRange(const S1, S2: string; const Index, Count: Integer): Integer;
begin
Result := System.String.Compare(S1, Index - 1, S2, Index - 1, Count, False);
end;
{$ELSE}
function StrCompareRange(const S1, S2: string; const Index, Count: Integer): Integer; assembler;
asm
TEST EAX, EAX
JZ @@Str1Null
TEST EDX, EDX
JZ @@StrNull
DEC ECX
JS @@StrNull
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX, Count
DEC EBX
JS @@NoWork
MOV ESI, EAX
MOV EDI, EDX
MOV EDX, [ESI - AnsiStrRecSize].TAnsiStrRec.Length
// # of chars in S1 - (Index - 1)
SUB EDX, ECX
JLE @@NoWork
// # of chars in S1 - (Count - 1)
SUB EDX, EBX
JLE @@NoWork
// move to index'th char
ADD ESI, ECX
MOV ECX, [EDI - AnsiStrRecSize].TAnsiStrRec.Length
DEC ECX
JS @@NoWork
// if Length(S2) > Count then ECX := Count else ECX := Length(S2)
CMP ECX, EBX
JLE @@Skip1
MOV ECX, EBX
@@Skip1:
XOR EAX, EAX
XOR EDX, EDX
@@Loop:
MOV AL, [ESI]
INC ESI
MOV DL, [EDI]
INC EDI
CMP AL, DL
JNE @@MisMatch
DEC ECX
JGE @@Loop
@@Match:
XOR EAX, EAX
POP EDI
POP ESI
POP EBX
JMP @@Exit
@@MisMatch:
SUB EAX, EDX
POP EDI
POP ESI
POP EBX
JMP @@Exit
@@NoWork:
MOV EAX, -2
POP EDI
POP ESI
POP EBX
JMP @@Exit
@@Str1Null:
MOV EAX, 0
TEST EDX, EDX
JZ @@Exit
@@StrNull:
MOV EAX, -1
@@Exit:
end;
{$ENDIF CLR}
function StrFillChar(const C: Char; Count: Integer): string;
{$IFDEF CLR}
var
sb: StringBuilder;
begin
sb := StringBuilder.Create(Count);
while Count > 0 do
begin
sb.Append(C);
Dec(Count);
end;
Result := sb.ToString();
end;
{$ELSE}
begin
SetLength(Result, Count);
if (Count > 0) then
FillChar(Result[1], Count, Ord(C));
end;
{$ENDIF CLR}
{$IFDEF CLR}
function StrFind(const Substr, S: string; const Index: Integer): Integer;
begin
Result := System.String(S).ToLower().IndexOf(System.String(SubStr).ToLower(), Index - 1) + 1;
end;
{$ELSE}
function StrFind(const Substr, S: string; const Index: Integer): Integer; assembler;
const
SearchChar: Byte = 0;
NumberOfChars: Integer = 0;
asm
// if SubStr = '' then Return := 0;
TEST EAX, EAX
JZ @@SubstrIsNull
// if Str = '' then Return := 0;
TEST EDX, EDX
JZ @@StrIsNull
// Index := Index - 1; if Index < 0 then Return := 0;
DEC ECX
JL @@IndexIsSmall
// EBX will hold the case table, ESI pointer to Str, EDI pointer
// to Substr and - # of chars in Substr to compare
PUSH EBX
PUSH ESI
PUSH EDI
// set the string pointers
MOV ESI, EDX
MOV EDI, EAX
// save the Index in EDX
MOV EDX, ECX
// temporary get the length of Substr and Str
MOV EBX, [EDI - AnsiStrRecSize].TAnsiStrRec.Length
MOV ECX, [ESI - AnsiStrRecSize].TAnsiStrRec.Length
// save the address of Str to compute the result
PUSH ESI
// dec the length of Substr because the first char is brought out of it
DEC EBX
JS @@NotFound
// #positions in Str to look at = Length(Str) - Length(Substr) - Index - 2
SUB ECX, EBX
JLE @@NotFound
SUB ECX, EDX
JLE @@NotFound
// # of chars in Substr to compare
MOV NumberOfChars, EBX
// point Str to Index'th char
ADD ESI, EDX
// load case map into EBX, and clear EAX
LEA EBX, AnsiCaseMap
XOR EAX, EAX
XOR EDX, EDX
// bring the first char out of the Substr and point Substr to the next char
MOV DL, [EDI]
INC EDI
// lower case it
MOV DL, [EBX + EDX]
MOV SearchChar, DL
JMP @@Find
@@FindNext:
// update the loop counter and check the end of string.
// if we reached the end, Substr was not found.
DEC ECX
JL @@NotFound
@@Find:
// get current char from the string, and point Str to the next one
MOV AL, [ESI]
INC ESI
// lower case current char
MOV AL, [EBX + EAX]
// does current char match primary search char? if not, go back to the main loop
CMP AL, SearchChar
JNE @@FindNext
@@Compare:
// # of chars in Substr to compare
MOV EDX, NumberOfChars
@@CompareNext:
// dec loop counter and check if we reached the end. If yes then we found it
DEC EDX
JL @@Found
// get the chars from Str and Substr, if they are equal then continue comparing
MOV AL, [ESI + EDX]
CMP AL, [EDI + EDX]
JE @@CompareNext
// otherwise try the reverse case. If they still don't match go back to the Find loop
MOV AL, [EBX + EAX + AnsiReOffset]
CMP AL, [EDI + EDX]
JNE @@FindNext
// if they matched, continue comparing
JMP @@CompareNext
@@Found:
// we found it, calculate the result
MOV EAX, ESI
POP ESI
SUB EAX, ESI
POP EDI
POP ESI
POP EBX
RET
@@NotFound:
// not found it, clear the result
XOR EAX, EAX
POP ESI
POP EDI
POP ESI
POP EBX
RET
@@IndexIsSmall:
@@StrIsNull:
// clear the result
XOR EAX, EAX
@@SubstrIsNull:
@@Exit:
end;
{$ENDIF CLR}
function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean;
begin
Result := StrPrefixIndex(S, Prefixes) > -1;
end;
function StrIndex(const S: string; const List: array of string): Integer;
var
I: Integer;
begin
Result := -1;
for I := Low(List) to High(List) do
begin
{$IFDEF CLR}
if SameText(S, List[I]) then
{$ELSE}
if AnsiSameText(S, List[I]) then
{$ENDIF CLR}
begin
Result := I;
Break;
end;
end;
end;
function StrILastPos(const SubStr, S: string): Integer;
begin
Result := StrLastPos(StrUpper(SubStr), StrUpper(S));
end;
function StrIPos(const SubStr, S: string): Integer;
begin
{$IFDEF CLR}
Result := Pos(SubStr.ToUpper, S.ToUpper);
{$ELSE}
Result := Pos(AnsiUpperCase(SubStr), AnsiUpperCase(S));
{$ENDIF CLR}
end;
function StrIsOneOf(const S: string; const List: array of string): Boolean;
begin
Result := StrIndex(S, List) > -1;
end;
function StrLastPos(const SubStr, S: string): Integer;
{$IFDEF CLR}
begin
Result := System.String(S).LastIndexOf(SubStr) + 1;
end;
{$ELSE}
var
Last, Current: PChar;
begin
Result := 0;
Last := nil;
Current := PChar(S);
while (Current <> nil) and (Current^ <> #0) do
begin
Current := AnsiStrPos(PChar(Current), PChar(SubStr));
if Current <> nil then
begin
Last := Current;
Inc(Current);
end;
end;
if Last <> nil then
Result := Abs((Longint(PChar(S)) - Longint(Last)) div SizeOf(Char)) + 1;
end;
{$ENDIF CLR}
// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*)
function StrMatch(const Substr, S: string; const Index: Integer): Integer;
{$IFDEF CLR}
begin
{ TODO : StrMatch }
Result := 0;
end;
{$ELSE}
assembler;
asm
// make sure that strings are not null
TEST EAX, EAX
JZ @@SubstrIsNull
TEST EDX, EDX
JZ @@StrIsNull
// limit index to satisfy 1 <= index, and dec it
DEC ECX
JL @@IndexIsSmall
// EBX will hold the case table, ESI pointer to Str, EDI pointer
// to Substr and EBP # of chars in Substr to compare
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
// set the string pointers
MOV ESI, EDX
MOV EDI, EAX
// save the Index in EDX
MOV EDX, ECX
// save the address of Str to compute the result
PUSH ESI
// temporary get the length of Substr and Str
MOV EBX, [EDI - AnsiStrRecSize].TAnsiStrRec.Length
MOV ECX, [ESI - AnsiStrRecSize].TAnsiStrRec.Length
// dec the length of Substr because the first char is brought out of it
DEC EBX
JS @@NotFound
// #positions in Str to look at = Length(Str) - Length(Substr) - Index - 2
SUB ECX, EBX
JLE @@NotFound
SUB ECX, EDX
JLE @@NotFound
// # of chars in Substr to compare
MOV EBP, EBX
// point Str to Index'th char
ADD ESI, EDX
// load case map into EBX, and clear EAX & ECX
LEA EBX, AnsiCaseMap
XOR EAX, EAX
XOR ECX, ECX
// bring the first char out of the Substr and point Substr to the next char
MOV CL, [EDI]
INC EDI
// lower case it
MOV CL, [EBX + ECX]
@@FindNext:
// get the current char from Str into al
MOV AL, [ESI]
INC ESI
// check the end of string
TEST AL, AL
JZ @@NotFound
CMP CL, '*' // Wild Card?
JE @@Compare
CMP CL, '?' // Wild Card?
JE @@Compare
// lower case current char
MOV AL, [EBX + EAX]
// check if the current char matches the primary search char,
// if not continue searching
CMP AL, CL
JNE @@FindNext
@@Compare:
// # of chars in Substr to compare }
MOV EDX, EBP
@@CompareNext:
// dec loop counter and check if we reached the end. If yes then we found it
DEC EDX
JL @@Found
// get the chars from Str and Substr, if they are equal then continue comparing
MOV AL, [EDI + EDX] // char from Substr
CMP AL, '*' // wild card?
JE @@CompareNext
CMP AL, '?' // wild card?
JE @@CompareNext
CMP AL, [ESI + EDX] // equal to PChar(Str)^ ?
JE @@CompareNext
MOV AL, [EBX + EAX + AnsiReOffset] // reverse case?
CMP AL, [ESI + EDX]
JNE @@FindNext // if still no, go back to the main loop
// if they matched, continue comparing
JMP @@CompareNext
@@Found:
// we found it, calculate the result
MOV EAX, ESI
POP ESI
SUB EAX, ESI
POP EBP
POP EDI
POP ESI
POP EBX
RET
@@NotFound:
// not found it, clear the result
XOR EAX, EAX
POP ESI
POP EBP
POP EDI
POP ESI
POP EBX
RET
@@IndexIsSmall:
@@StrIsNull:
// clear the result
XOR EAX, EAX
@@SubstrIsNull:
@@Exit:
end;
{$ENDIF CLR}
// Derived from "Like" by Michael Winter
function StrMatches(const Substr, S: string; const Index: Integer): Boolean;
{$IFDEF CLR}
begin
Result := Substr = S;
{ TODO : StrMatches }
end;
{$ELSE}
var
StringPtr: PChar;
PatternPtr: PChar;
StringRes: PChar;
PatternRes: PChar;
begin
if SubStr = '' then
raise EJclStringError.CreateRes(@RsBlankSearchString);
Result := SubStr = '*';
if Result or (S = '') then
Exit;
StringPtr := PChar(@S[Index]);
PatternPtr := PChar(SubStr);
StringRes := nil;
PatternRes := nil;
repeat
repeat
case PatternPtr^ of
#0:
begin
Result := StringPtr^ = #0;
if Result or (StringRes = nil) or (PatternRes = nil) then
Exit;
StringPtr := StringRes;
PatternPtr := PatternRes;
Break;
end;
'*':
begin
Inc(PatternPtr);
PatternRes := PatternPtr;
Break;
end;
'?':
begin
if StringPtr^ = #0 then
Exit;
Inc(StringPtr);
Inc(PatternPtr);
end;
else
begin
if StringPtr^ = #0 then
Exit;
if StringPtr^ <> PatternPtr^ then
begin
if (StringRes = nil) or (PatternRes = nil) then
Exit;
StringPtr := StringRes;
PatternPtr := PatternRes;
Break;
end
else
begin
Inc(StringPtr);
Inc(PatternPtr);
end;
end;
end;
until False;
repeat
case PatternPtr^ of
#0:
begin
Result := True;
Exit;
end;
'*':
begin
Inc(PatternPtr);
PatternRes := PatternPtr;
end;
'?':
begin
if StringPtr^ = #0 then
Exit;
Inc(StringPtr);
Inc(PatternPtr);
end;
else
begin
repeat
if StringPtr^ = #0 then
Exit;
if StringPtr^ = PatternPtr^ then
Break;
Inc(StringPtr);
until False;
Inc(StringPtr);
StringRes := StringPtr;
Inc(PatternPtr);
Break;
end;
end;
until False;
until False;
end;
{$ENDIF CLR}
function StrNPos(const S, SubStr: string; N: Integer): Integer;
var
I, P: Integer;
begin
if N < 1 then
begin
Result := 0;
Exit;
end;
Result := StrSearch(SubStr, S, 1);
I := 1;
while I < N do
begin
P := StrSearch(SubStr, S, Result + 1);
if P = 0 then
begin
Result := 0;
Break;
end
else
begin
Result := P;
Inc(I);
end;
end;
end;
function StrNIPos(const S, SubStr: string; N: Integer): Integer;
var
I, P: Integer;
begin
if N < 1 then
begin
Result := 0;
Exit;
end;
Result := StrFind(SubStr, S, 1);
I := 1;
while I < N do
begin
P := StrFind(SubStr, S, Result + 1);
if P = 0 then
begin
Result := 0;
Break;
end
else
begin
Result := P;
Inc(I);
end;
end;
end;
function StrPrefixIndex(const S: string; const Prefixes: array of string): Integer;
var
I: Integer;
Test: string;
begin
Result := -1;
for I := Low(Prefixes) to High(Prefixes) do
begin
Test := StrLeft(S, Length(Prefixes[I]));
{$IFDEF CLR}
if SameText(Test, Prefixes[I]) then
{$ELSE}
if AnsiSameText(Test, Prefixes[I]) then
{$ENDIF CLR}
begin
Result := I;
Break;
end;
end;
end;
{$IFDEF CLR}
function StrSearch(const Substr, S: string; const Index: Integer): Integer;
begin
Result := System.String(S).IndexOf(SubStr, Index - 1) + 1;
end;
{$ELSE}
function StrSearch(const Substr, S: string; const Index: Integer): Integer; assembler;
asm
// make sure that strings are not null
TEST EAX, EAX
JZ @@SubstrIsNull
TEST EDX, EDX
JZ @@StrIsNull
// limit index to satisfy 1 <= index, and dec it
DEC ECX
JL @@IndexIsSmall
// ebp will hold # of chars in Substr to compare, esi pointer to Str,
// edi pointer to Substr, ebx primary search char
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
// set the string pointers
MOV ESI, EDX
MOV EDI, EAX
// save the (Index - 1) in edx
MOV EDX, ECX
// save the address of Str to compute the result
PUSH ESI
// temporary get the length of Substr and Str
MOV EBX, [EDI-AnsiStrRecSize].TAnsiStrRec.Length
MOV ECX, [ESI-AnsiStrRecSize].TAnsiStrRec.Length
// dec the length of Substr because the first char is brought out of it
DEC EBX
JS @@NotFound
// # of positions in Str to look at = Length(Str) - Length(Substr) - Index - 2
SUB ECX, EBX
JLE @@NotFound
SUB ECX, EDX
JLE @@NotFound
// point Str to Index'th char
ADD ESI, EDX
// # of chars in Substr to compare
MOV EBP, EBX
// clear EAX & ECX (working regs)
XOR EAX, EAX
XOR EBX, EBX
// bring the first char out of the Substr, and
// point Substr to the next char
MOV BL, [EDI]
INC EDI
// jump into the loop
JMP @@Find
@@FindNext:
// update the loop counter and check the end of string.
// if we reached the end, Substr was not found.
DEC ECX
JL @@NotFound
@@Find:
// get current char from the string, and /point Str to the next one.
MOV AL, [ESI]
INC ESI
// does current char match primary search char? if not, go back to the main loop
CMP AL, BL
JNE @@FindNext
// otherwise compare SubStr
@@Compare:
// move # of char to compare into edx, edx will be our compare loop counter.
MOV EDX, EBP
@@CompareNext:
// check if we reached the end of Substr. If yes we found it.
DEC EDX
JL @@Found
// get last chars from Str and SubStr and compare them,
// if they don't match go back to out main loop.
MOV AL, [EDI+EDX]
CMP AL, [ESI+EDX]
JNE @@FindNext
// if they matched, continue comparing
JMP @@CompareNext
@@Found:
// we found it, calculate the result and exit.
MOV EAX, ESI
POP ESI
SUB EAX, ESI
POP EBP
POP EDI
POP ESI
POP EBX
RET
@@NotFound:
// not found it, clear result and exit.
XOR EAX, EAX
POP ESI
POP EBP
POP EDI
POP ESI
POP EBX
RET
@@IndexIsSmall:
@@StrIsNull:
// clear result and exit.
XOR EAX, EAX
@@SubstrIsNull:
@@Exit:
end;
{$ENDIF CLR}
//=== String Extraction ======================================================
function StrAfter(const SubStr, S: string): string;
var
P: Integer;
begin
P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos
if P <= 0 then
Result := '' // substr not found -> nothing after it
else
Result := StrRestOf(S, P + Length(SubStr));
end;
function StrBefore(const SubStr, S: string): string;
var
P: Integer;
begin
P := StrFind(SubStr, S, 1);
if P <= 0 then
Result := S
else
Result := StrLeft(S, P - 1);
end;
function StrBetween(const S: string; const Start, Stop: Char): string;
var
PosStart, PosEnd: Integer;
L: Integer;
begin
PosStart := Pos(Start, S);
PosEnd := StrSearch(Stop, S, PosStart+1); // PosEnd has to be after PosStart.
if (PosStart > 0) and (PosEnd > PosStart) then
begin
L := PosEnd - PosStart;
Result := Copy(S, PosStart + 1, L - 1);
end
else
Result := '';
end;
function StrChopRight(const S: string; N: Integer): string;
begin
Result := Copy(S, 1, Length(S) - N);
end;
function StrLeft(const S: string; Count: Integer): string;
begin
Result := Copy(S, 1, Count);
end;
function StrMid(const S: string; Start, Count: Integer): string;
begin
Result := Copy(S, Start, Count);
end;
function StrRestOf(const S: string; N: Integer ): string;
begin
Result := Copy(S, N, (Length(S) - N + 1));
end;
function StrRight(const S: string; Count: Integer): string;
begin
Result := Copy(S, Length(S) - Count + 1, Count);
end;
//=== Character (do we have it ;) ============================================
function CharEqualNoCase(const C1, C2: Char): Boolean;
begin
//if they are not equal chars, may be same letter different case
Result := (C1 = C2) or
(CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2)));
end;
function CharIsAlpha(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsLetter(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_ALPHA) <> 0;
{$ENDIF CLR}
end;
function CharIsAlphaNum(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsLetterOrDigit(C);
{$ELSE}
Result := ((AnsiCharTypes[C] and C1_ALPHA) <> 0) or
((AnsiCharTypes[C] and C1_DIGIT) <> 0);
{$ENDIF CLR}
end;
function CharIsBlank(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsSurrogate(C);
{$ELSE}
Result := ((AnsiCharTypes[C] and C1_BLANK) <> 0);
{$ENDIF CLR}
end;
function CharIsControl(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsControl(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_CNTRL) <> 0;
{$ENDIF CLR}
end;
function CharIsDelete(const C: Char): Boolean;
begin
Result := (C = #8);
end;
function CharIsDigit(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsDigit(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_DIGIT) <> 0;
{$ENDIF CLR}
end;
function CharIsLower(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsLower(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_LOWER) <> 0;
{$ENDIF CLR}
end;
function CharIsNumberChar(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsDigit(C) or
{$ELSE}
Result := ((AnsiCharTypes[C] and C1_DIGIT) <> 0) or
{$ENDIF CLR}
(C in AnsiSigns) or (C = DecimalSeparator);
end;
function CharIsPrintable(const C: Char): Boolean;
begin
Result := not CharIsControl(C);
end;
function CharIsPunctuation(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsPunctuation(C);
{$ELSE}
Result := ((AnsiCharTypes[C] and C1_PUNCT) <> 0);
{$ENDIF CLR}
end;
function CharIsReturn(const C: Char): Boolean;
begin
Result := (C = AnsiLineFeed) or (C = AnsiCarriageReturn);
end;
function CharIsSpace(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsSeparator(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_SPACE) <> 0;
{$ENDIF CLR}
end;
function CharIsUpper(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsUpper(C);
{$ELSE}
Result := (AnsiCharTypes[C] and C1_UPPER) <> 0;
{$ENDIF CLR}
end;
function CharIsWhiteSpace(const C: Char): Boolean;
begin
{$IFDEF CLR}
Result := System.Char.IsWhiteSpace(C);
{$ELSE}
Result := C in AnsiWhiteSpace;
{$ENDIF CLR}
end;
{$IFNDEF CLR}
function CharType(const C: Char): Word;
begin
Result := AnsiCharTypes[C];
end;
//=== PCharVector ============================================================
function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector;
var
I: Integer;
S: string;
List: array of PChar;
begin
Assert(Source <> nil);
Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar));
SetLength(List, Source.Count + SizeOf(Char));
for I := 0 to Source.Count - 1 do
begin
S := Source[I];
List[I] := StrAlloc(Length(S) + SizeOf(Char));
StrPCopy(List[I], S);
end;
List[Source.Count] := nil;
Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar));
Result := Dest;
end;
function PCharVectorCount(Source: PCharVector): Integer;
var
P: PChar;
begin
Result := 0;
if Source <> nil then
begin
P := Source^;
while P <> nil do
begin
Inc(Result);
P := PCharVector(Longint(Source) + (SizeOf(PChar) * Result))^;
end;
end;
end;
procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector);
var
I, Count: Integer;
List: array of PChar;
begin
Assert(Dest <> nil);
if Source <> nil then
begin
Count := PCharVectorCount(Source);
SetLength(List, Count);
Move(Source^, List[0], Count * SizeOf(PChar));
Dest.BeginUpdate;
try
Dest.Clear;
for I := 0 to Count - 1 do
Dest.Add(List[I]);
finally
Dest.EndUpdate;
end;
end;
end;
procedure FreePCharVector(var Dest: PCharVector);
var
I, Count: Integer;
List: array of PChar;
begin
if Dest <> nil then
begin
Count := PCharVectorCount(Dest);
SetLength(List, Count);
Move(Dest^, List[0], Count * SizeOf(PChar));
for I := 0 to Count - 1 do
StrDispose(List[I]);
FreeMem(Dest, (Count + 1) * SizeOf(PChar));
Dest := nil;
end;
end;
{$ENDIF ~CLR}
//=== Character Transformation Routines ======================================
function CharHex(const C: Char): Byte;
begin
Result := $FF;
if C in AnsiDecDigits then
Result := Ord(CharUpper(C)) - Ord('0')
else
begin
if C in AnsiHexDigits then
Result := Ord(CharUpper(C)) - (Ord('A')) + 10;
end;
end;
function CharLower(const C: Char): Char;
begin
{$IFDEF CLR}
Result := System.Char.ToLower(C);
{$ELSE}
Result := AnsiCaseMap[Ord(C) + AnsiLoOffset];
{$ENDIF CLR}
end;
function CharToggleCase(const C: Char): Char;
begin
{$IFDEF CLR}
if System.Char.IsUpper(C) then
Result := System.Char.ToLower(C)
else
if System.Char.IsLower(C) then
Result := System.Char.ToUpper(C)
else
Result := C;
{$ELSE}
Result := AnsiCaseMap[Ord(C) + AnsiReOffset];
{$ENDIF CLR}
end;
function CharUpper(const C: Char): Char;
begin
{$IFDEF CLR}
Result := System.Char.ToUpper(C);
{$ELSE}
Result := AnsiCaseMap[Ord(C) + AnsiUpOffset];
{$ENDIF CLR}
end;
//=== Character Search and Replace ===========================================
function CharLastPos(const S: string; const C: Char; const Index: Integer): Integer;
begin
if (Index > 0) and (Index <= Length(S)) then
begin
for Result := Length(S) downto Index do
if S[Result] = C then
Exit;
end;
Result := 0;
end;
function CharPos(const S: string; const C: Char; const Index: Integer): Integer;
begin
if (Index > 0) and (Index <= Length(S)) then
begin
for Result := Index to Length(S) do
if S[Result] = C then
Exit;
end;
Result := 0;
end;
function CharIPos(const S: string; C: Char; const Index: Integer): Integer;
begin
if (Index > 0) and (Index <= Length(S)) then
begin
C := CharUpper(C);
for Result := Index to Length(S) do
{$IFDEF CLR}
if System.Char.ToUpper(S[Result]) = C then
{$ELSE}
if AnsiCaseMap[Ord(S[Result]) + AnsiUpOffset] = C then
{$ENDIF CLR}
Exit;
end;
Result := 0;
end;
function CharReplace(var S: string; const Search, Replace: Char): Integer;
{$IFDEF CLR}
var
I: Integer;
begin
Result := 0;
for I := 1 to Length(S) do
if S[I] = Search then
Inc(Result);
S := S.Replace(Search, Replace);
end;
{$ELSE}
var
P: PChar;
Index, Len: Integer;
begin
Result := 0;
if Search <> Replace then
begin
UniqueString(S);
P := PChar(S);
Len := Length(S);
for Index := 0 to Len-1 do
begin
if P^ = Search then
begin
P^ := Replace;
Inc(Result);
end;
Inc(P);
end;
end;
end;
{$ENDIF CLR}
{$IFNDEF CLR}
//=== MultiSz ================================================================
function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz;
var
I, TotalLength: Integer;
P: PMultiSz;
begin
Assert(Source <> nil);
TotalLength := 1;
for I := 0 to Source.Count - 1 do
if Source[I] = '' then
raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem)
else
Inc(TotalLength, StrLen(PChar(Source[I])) + 1);
AllocateMultiSz(Dest, TotalLength);
P := Dest;
for I := 0 to Source.Count - 1 do
begin
P := StrECopy(P, PChar(Source[I]));
Inc(P);
end;
P^ := #0;
Result := Dest;
end;
procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz);
var
P: PMultiSz;
begin
Assert(Dest <> nil);
Dest.BeginUpdate;
try
Dest.Clear;
if Source <> nil then
begin
P := Source;
while P^ <> #0 do
begin
Dest.Add(P);
P := StrEnd(P);
Inc(P);
end;
end;
finally
Dest.EndUpdate;
end;
end;
function MultiSzLength(const Source: PMultiSz): Integer;
var
P: PMultiSz;
begin
Result := 0;
if Source <> nil then
begin
P := Source;
repeat
Inc(Result, StrLen(P) + 1);
P := StrEnd(P);
Inc(P);
until P^ = #0;
Inc(Result);
end;
end;
procedure AllocateMultiSz(var Dest: PMultiSz; Len: Integer);
begin
if Len > 0 then
GetMem(Dest, Len * SizeOf(Char))
else
Dest := nil;
end;
procedure FreeMultiSz(var Dest: PMultiSz);
begin
if Dest <> nil then
FreeMem(Dest);
Dest := nil;
end;
function MultiSzDup(const Source: PMultiSz): PMultiSz;
var
Len: Integer;
begin
if Source <> nil then
begin
Len := MultiSzLength(Source);
AllocateMultiSz(Result, Len);
Move(Source^, Result^, Len * SizeOf(Char));
end
else
Result := nil;
end;
function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz;
var
I, TotalLength: Integer;
P: PWideMultiSz;
begin
Assert(Source <> nil);
TotalLength := 1;
for I := 0 to Source.Count - 1 do
if Source[I] = '' then
raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem)
else
Inc(TotalLength, StrLenW(PWideChar(Source[I])) + 1);
AllocateWideMultiSz(Dest, TotalLength);
P := Dest;
for I := 0 to Source.Count - 1 do
begin
P := StrECopyW(P, PWideChar(Source[I]));
Inc(P);
end;
P^:= #0;
Result := Dest;
end;
procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz);
var
P: PWideMultiSz;
begin
Assert(Dest <> nil);
Dest.BeginUpdate;
try
Dest.Clear;
if Source <> nil then
begin
P := Source;
while P^ <> #0 do
begin
Dest.Add(P);
P := StrEndW(P);
Inc(P);
end;
end;
finally
Dest.EndUpdate;
end;
end;
function WideMultiSzLength(const Source: PWideMultiSz): Integer;
var
P: PWideMultiSz;
begin
Result := 0;
if Source <> nil then
begin
P := Source;
repeat
Inc(Result, StrLenW(P) + 1);
P := StrEndW(P);
Inc(P);
until P^ = #0;
Inc(Result);
end;
end;
procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: Integer);
begin
if Len > 0 then
GetMem(Dest, Len * SizeOf(WideChar))
else
Dest := nil;
end;
procedure FreeWideMultiSz(var Dest: PWideMultiSz);
begin
if Dest <> nil then
FreeMem(Dest);
Dest := nil;
end;
function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz;
var
Len: Integer;
begin
if Source <> nil then
begin
Len := WideMultiSzLength(Source);
AllocateWideMultiSz(Result, Len);
Move(Source^, Result^, Len * SizeOf(WideChar));
end
else
Result := nil;
end;
{$ENDIF ~CLR}
//=== TStrings Manipulation ==================================================
procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);
var
I, L: Integer;
Left: string;
begin
Assert(List <> nil);
List.BeginUpdate;
try
List.Clear;
L := Length(Sep);
I := Pos(Sep, S);
while I > 0 do
begin
Left := StrLeft(S, I - 1);
if (Left <> '') or AllowEmptyString then
List.Add(Left);
Delete(S, 1, I + L - 1);
I := Pos(Sep, S);
end;
if S <> '' then
List.Add(S); // Ignore empty strings at the end.
finally
List.EndUpdate;
end;
end;
procedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);
var
I, L: Integer;
LowerCaseStr: string;
Left: string;
begin
Assert(List <> nil);
LowerCaseStr := StrLower(S);
Sep := StrLower(Sep);
L := Length(Sep);
I := Pos(Sep, LowerCaseStr);
List.BeginUpdate;
try
List.Clear;
while I > 0 do
begin
Left := StrLeft(S, I - 1);
if (Left <> '') or AllowEmptyString then
List.Add(Left);
Delete(S, 1, I + L - 1);
Delete(LowerCaseStr, 1, I + L - 1);
I := Pos(Sep, LowerCaseStr);
end;
if S <> '' then
List.Add(S); // Ignore empty strings at the end.
finally
List.EndUpdate;
end;
end;
function StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean): string;
var
I, L: Integer;
begin
Result := '';
for I := 0 to List.Count - 1 do
begin
if (List[I] <> '') or AllowEmptyString then
begin
// don't combine these into one addition, somehow it hurts performance
Result := Result + List[I];
Result := Result + Sep;
end;
end;
// remove terminating separator
if List.Count <> 0 then
begin
L := Length(Sep);
Delete(Result, Length(Result) - L + 1, L);
end;
end;
procedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean);
var
I: Integer;
begin
Assert(List <> nil);
List.BeginUpdate;
try
for I := List.Count - 1 downto 0 do
begin
List[I] := Trim(List[I]);
if (List[I] = '') and DeleteIfEmpty then
List.Delete(I);
end;
finally
List.EndUpdate;
end;
end;
procedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean);
var
I: Integer;
begin
Assert(List <> nil);
List.BeginUpdate;
try
for I := List.Count - 1 downto 0 do
begin
List[I] := TrimRight(List[I]);
if (List[I] = '') and DeleteIfEmpty then
List.Delete(I);
end;
finally
List.EndUpdate;
end;
end;
procedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean);
var
I: Integer;
begin
Assert(List <> nil);
List.BeginUpdate;
try
for I := List.Count - 1 downto 0 do
begin
List[I] := TrimLeft(List[I]);
if (List[I] = '') and DeleteIfEmpty then
List.Delete(I);
end;
finally
List.EndUpdate;
end;
end;
function AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean;
begin
Assert(Strings <> nil);
Result := Unique and (Strings.IndexOf(S) <> -1);
if not Result then
Result := Strings.Add(S) > -1;
end;
//=== Miscellaneous ==========================================================
function BooleanToStr(B: Boolean): string;
const
Bools: array [Boolean] of string = ('False', 'True');
begin
Result := Bools[B];
end;
function FileToString(const FileName: string): AnsiString;
var
fs: TFileStream;
Len: Integer;
{$IFDEF CLR}
Buf: array of Byte;
{$ENDIF CLR}
begin
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Len := fs.Size;
SetLength(Result, Len);
if Len > 0 then
{$IFDEF CLR}
begin
SetLength(Buf, Len);
fs.ReadBuffer(Buf, Len);
Result := Buf;
end;
{$ELSE}
fs.ReadBuffer(Result[1], Len);
{$ENDIF CLR}
finally
fs.Free;
end;
end;
procedure StringToFile(const FileName: string; const Contents: AnsiString);
var
fs: TFileStream;
Len: Integer;
begin
fs := TFileStream.Create(FileName, fmCreate);
try
Len := Length(Contents);
if Len > 0 then
{$IFDEF CLR}
fs.WriteBuffer(BytesOf(Contents), Len);
{$ELSE}
fs.WriteBuffer(Contents[1], Len);
{$ENDIF CLR}
finally
fs.Free;
end;
end;
function StrToken(var S: string; Separator: Char): string;
var
I: Integer;
begin
I := Pos(Separator, S);
if I <> 0 then
begin
Result := Copy(S, 1, I - 1);
Delete(S, 1, I);
end
else
begin
Result := S;
S := '';
end;
end;
{$IFDEF CLR}
procedure StrTokens(const S: string; const List: TStrings);
var
Start: Integer;
Token: string;
Done: Boolean;
begin
Assert(List <> nil);
if List = nil then
Exit;
List.BeginUpdate;
try
List.Clear;
Start := 0;
repeat
Done := StrWord(S, Start, Token);
if Token <> '' then
List.Add(Token);
until Done;
finally
List.EndUpdate;
end;
end;
function StrWord(const S: string; var Index: Integer; out Word: string): Boolean;
var
Start: Integer;
begin
Word := '';
if (S = nil) or (S = '') then
begin
Result := True;
Exit;
end;
Start := Index;
Result := False;
while True do
begin
case S[Index] of
#0:
begin
if Start <> 0 then
Word := S.Substring(Start, Index - Start);
Result := True;
Exit;
end;
AnsiSpace, AnsiLineFeed, AnsiCarriageReturn:
begin
if Start <> 0 then
begin
Word := S.Substring(Start, Index - Start);
Exit;
end
else
while (S[Index] in [AnsiSpace, AnsiLineFeed, AnsiCarriageReturn]) do
Inc(Index);
end;
else
if Start = 0 then
Start := Index;
Inc(Index);
end;
end;
end;
{$ELSE}
procedure StrTokens(const S: string; const List: TStrings);
var
Start: PChar;
Token: string;
Done: Boolean;
begin
Assert(List <> nil);
if List = nil then
Exit;
List.BeginUpdate;
try
List.Clear;
Start := Pointer(S);
repeat
Done := StrWord(Start, Token);
if Token <> '' then
List.Add(Token);
until Done;
finally
List.EndUpdate;
end;
end;
function StrWord(var S: PChar; out Word: string): Boolean;
var
Start: PChar;
begin
Word := '';
if S = nil then
begin
Result := True;
Exit;
end;
Start := nil;
Result := False;
while True do
begin
case S^ of
#0:
begin
if Start <> nil then
SetString(Word, Start, S - Start);
Result := True;
Exit;
end;
AnsiSpace, AnsiLineFeed, AnsiCarriageReturn:
begin
if Start <> nil then
begin
SetString(Word, Start, S - Start);
Exit;
end
else
while (S^ in [AnsiSpace, AnsiLineFeed, AnsiCarriageReturn]) do
Inc(S);
end;
else
if Start = nil then
Start := S;
Inc(S);
end;
end;
end;
{$ENDIF ~CLR}
procedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings);
var
Token: string;
begin
Assert(List <> nil);
if List = nil then
Exit;
List.BeginUpdate;
try
List.Clear;
while S <> '' do
begin
Token := StrToken(S, Separator);
List.Add(Token);
end;
finally
List.EndUpdate;
end;
end;
function StrToFloatSafe(const S: string): Float;
var
Temp: string;
I, J, K: Integer;
SwapSeparators, IsNegative: Boolean;
DecSep: Char;
ThouSep: Char;
{$IFDEF CLR}
sb: StringBuilder;
{$ENDIF CLR}
begin
{$IFDEF CLR}
DecSep := Char(DecimalSeparator[1]);
ThouSep := Char(ThousandSeparator[1]);
{$ELSE}
DecSep := DecimalSeparator;
ThouSep := ThousandSeparator;
{$ENDIF CLR}
Temp := S;
SwapSeparators := False;
IsNegative := False;
J := 0;
for I := 1 to Length(Temp) do
begin
if Temp[I] = '-' then
IsNegative := not IsNegative
else
if not (Temp[I] in [' ', '(', '+']) then
begin
// if it appears prior to any digit, it has to be a decimal separator
SwapSeparators := Temp[I] = ThouSep;
J := I;
Break;
end;
end;
if not SwapSeparators then
begin
K := CharPos(Temp, DecSep);
SwapSeparators :=
// if it appears prior to any digit, it has to be a decimal separator
(K > J) and
// if it appears multiple times, it has to be a thousand separator
((StrCharCount(Temp, DecSep) > 1) or
// we assume (consistent with Windows Platform SDK documentation),
// that thousand separators appear only to the left of the decimal
(K < CharPos(Temp, ThouSep)));
end;
if SwapSeparators then
begin
// assume a numerical string from a different locale,
// where DecimalSeparator and ThousandSeparator are exchanged
{$IFDEF CLR}
sb := StringBuilder.Create(Temp);
for I := 0 to sb.Length - 1 do
if sb[I] = DecimalSeparator then
sb[I] := ThouSep
else
if sb[I] = ThousandSeparator then
sb[I] := DecSep;
Temp := sb.ToString;
{$ELSE}
for I := 1 to Length(Temp) do
if Temp[I] = DecSep then
Temp[I] := ThouSep
else
if Temp[I] = ThouSep then
Temp[I] := DecSep;
{$ENDIF CLR}
end;
Temp := StrKeepChars(Temp, AnsiDecDigits + [AnsiChar(DecSep)]);
if Length(Temp) > 0 then
begin
if Temp[1] = DecSep then
Temp := '0' + Temp;
if Temp[Length(Temp)] = DecSep then
Temp := Temp + '0';
Result := StrToFloat(Temp);
if IsNegative then
Result := -Result;
end
else
Result := 0.0;
end;
function StrToIntSafe(const S: string): Integer;
begin
Result := Trunc(StrToFloatSafe(S));
end;
procedure StrNormIndex(const StrLen: Integer; var Index: Integer; var Count: Integer); overload;
begin
Index := Max(1, Min(Index, StrLen+1));
Count := Max(0, Min(Count, StrLen+1 - Index));
end;
{$IFDEF CLR}
function ArrayOf(List: TStrings): TDynStringArray;
var
I: Integer;
begin
if List <> nil then
begin
SetLength(Result, List.Count);
for I := 0 to List.Count - 1 do
Result[I] := List[I];
end
else
Result := nil;
end;
{$ENDIF CLR}
{$IFDEF COMPILER5} // missing Delphi 5 functions
function TryStrToInt(const S: string; out Value: Integer): Boolean;
var
Err: Integer;
begin
Val(S, Value, Err);
Result := Err = 0;
end;
function TryStrToInt64(const S: string; out Value: Int64): Boolean;
var
Err: Integer;
begin
Val(S, Value, Err);
Result := Err = 0;
end;
function TryStrToFloat(const S: string; out Value: Extended): Boolean;
begin
Result := TextToFloat(PChar(S), Value, fvExtended);
end;
function TryStrToFloat(const S: string; out Value: Double): Boolean;
var
F: Extended;
begin
Result := TryStrToFloat(S, F);
if Result then
Value := F;
end;
function TryStrToFloat(const S: string; out Value: Single): Boolean;
var
F: Extended;
begin
Result := TryStrToFloat(S, F);
if Result then
Value := F;
end;
function TryStrToCurr(const S: string; out Value: Currency): Boolean;
begin
Result := TextToFloat(PChar(S), Value, fvCurrency);
end;
{$ENDIF COMPILER5}
{$IFNDEF CLR}
initialization
LoadCharTypes; // this table first
LoadCaseMap; // or this function does not work
{$ENDIF ~CLR}
// History:
// MT:
// - StrIToStrings default parameter now true
// - StrToStrings default parameter now true
// - Rewrote StrSmartCase to fix a bug.
// - Fixed a bug in StrIsAlphaNumUnderscore
// - Fixed a bug in StrIsSubset
// - Simplified StrLower
// - Fixed a bug in StrRepeatLength
// - Fixed a bug in StrLastPos
// - Added function StrTrimCharsRight (Leonard Wennekers)
// - Added function StrTrimCharsLeft (Leonard Wennekers)
// - Added StrNormIndex function (Alexander Radchenko)
// - Changed Assert in StrTokens/ to If List <> nil
// - Deleted an commented out version of StrReplace. If anyone ever want to finish the old
// version please go the archive version 0.39
// - Modified StrFillChar a little bit (added an if for count > 0)
// - StrCharPosLower (Jean-Fabien Connault)
// - StrCharPosUpper (Jean-Fabien Connault)
// - Changed to 100 chars per line style
// - Note to Marcel: Have a look at StrToStrings and StrItoStrings. They are untested but
// should work more or less equal to the BreakApart functions by JFC.
// - Changed StrNPos for special case
// - Changed StrIPos for special case
// - Fixed a bug in CharPos : didn'T work if index = length(s)
// - Fixed a bug in CharIPos : didn'T work if index = length(s)
// 2003-02-25, Robert Rossmair
// - Linux port (implemented LoadCharTypes & LoadCaseMap)
// 2002-01-20, Marcel van Brakel
// - added StrIToStrings to interface section
// - added AllowEmptyString parameter to StringsToStr function
// - added AddStringToStrings() by Jeff
// $Log: JclStrings.pas,v $
// Revision 1.46 2006/01/15 19:10:44 ahuser
// Added RegRead*Ex functions
// RegRead*Def functions do not raise exceptions anymore (makes debugging easier)
//
// Revision 1.45 2005/11/22 07:02:37 marquardt
// Fixed StrSmartCase uppercasing delimiters if they happen to be letters
//
// Revision 1.44 2005/10/25 12:52:23 outchy
// First corrections of IT#3259.
// StrReplace, StrLastPos, StrMatches are NOT fixed.
//
// Revision 1.43 2005/10/24 19:16:53 ahuser
// more .NET support
//
// Revision 1.42 2005/10/17 09:16:59 rikbarker
// Fixed range check crashes in StrOemToAnsi and StrAnsiToOem when passed an empty string. Both could probably do with rewriting to use non-obsoleted functions CharToOemBuff and OemToCharBuff, long term.
//
// Revision 1.41 2005/08/11 18:11:25 ahuser
// Added MoveChar function
//
// Revision 1.40 2005/08/09 10:30:21 ahuser
// JCL.NET changes
//
// Revision 1.39 2005/05/05 20:08:44 ahuser
// JCL.NET support
//
// Revision 1.37 2005/03/08 16:10:08 marquardt
// standard char sets extended and used, some optimizations for string literals
//
// Revision 1.36 2005/03/08 08:33:17 marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.35 2005/02/24 16:34:40 marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.34 2005/02/05 03:45:35 rrossmair
// - fixed issue #0002455 (Calculation of ResultLength inappropriate in StrReplace)
//
// Revision 1.33 2005/01/06 18:48:31 marquardt
// AnsiLineBreak, AnsiLineFeed, AnsiCarriageReturn, AnsiCrLf moved to JclBase JclStrings now reexports the names
//
// Revision 1.32 2004/12/23 04:31:43 rrossmair
// - check-in for JCL 1.94 RC 1
//
// Revision 1.31 2004/10/18 04:54:42 marquardt
// remove PH contributor
//
// Revision 1.30 2004/10/17 20:25:21 mthoma
// style cleaning, adjusting contributors
//
// Revision 1.29 2004/10/11 14:54:38 marquardt
// MultiSz finetuning
//
// Revision 1.28 2004/10/11 08:13:03 marquardt
// cleaning of JclStrings
//
// Revision 1.27 2004/10/10 12:52:12 marquardt
// DestroyEnvironmentBlock introduced
//
// Revision 1.26 2004/09/30 13:11:27 marquardt
// remove contributions
//
// Revision 1.25 2004/09/30 07:50:29 marquardt
// remove contributions
//
// Revision 1.24 2004/08/03 07:22:37 marquardt
// resourcestring cleanup
//
// Revision 1.23 2004/07/30 07:20:25 marquardt
// fixing TStringLists, adding BeginUpdate/EndUpdate
//
// Revision 1.22 2004/06/14 06:24:52 marquardt
// style cleaning IFDEF
//
// Revision 1.21 2004/05/30 23:54:42 rrossmair
// Processed documentation TODOs
//
// Revision 1.20 2004/05/08 08:44:17 rrossmair
// introduced & applied symbol HAS_UNIT_LIBC
//
// Revision 1.19 2004/05/06 16:22:27 rrossmair
// fixed LoadCaseMap for Kylix
//
// Revision 1.18 2004/05/06 05:09:55 rrossmair
// Changes for FPC v1.9.4 compatibility
//
// Revision 1.17 2004/05/05 00:11:24 mthoma
// Updated headers: Added donors as contributors, adjusted the initial authors, added cvs names when they were not obvious. Changed $data to $date where necessary,
//
// Revision 1.16 2004/04/19 06:12:34 rrossmair
// AddStringToStrings help TODO done
//
// Revision 1.15 2004/04/14 20:39:59 mthoma
// Reintroduced StrIsNumber as StrConsistsofNumberChars, copied local function StrEndW from JclUnicode to get rid of that dependency.
//
// Revision 1.14 2004/04/12 22:07:45
// Bugfix: StringsToMultiString, MultiStringToStrings,
// empty list entries are not allowed
// Add: StringsToMultiWideString, MultiWideStringToStrings
//
// Revision 1.13 2004/04/11 15:58:25 mthoma
// Fixed #1119. Removed StrIsNumber (see bugnote), renamed CharIsNumber to CharisNumberChar. Changed some Strings to string (unit now compiles also in H- mode).
//
// Revision 1.12 2004/04/09 20:35:14 mthoma
// Added StrLastPos. changed $Data$ to $Date: 2006/01/15 19:10:44 $
//
// Revision 1.11 2004/04/08 19:40:26 mthoma
// Fixed 0000947, 0001060 (StrBetween with same start/end symbol problem). Added a note to the docs.
//
// Revision 1.10 2004/04/06 04:31:32
// Add functions for String <--> MultiString conversion
//
end.
Reference in New Issue View Git Blame Copy Permalink