{**************************************************************************************************} { } { 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 (ahuser) } { Anthony Steele } { Azret Botash } { Barry Kelly } { Huanlin Tsai } { Jack N.A. Bakker } { Jean-Fabien Connault (cycocrew) } { John C Molyneux } { Kiriakos Vlahos } { Leonard Wennekers } { Marcel Bestebroer } { Martin Kimmings } { Martin Kubecka } { Massimo Maria Ghisalberti } { Matthias Thoma (mthoma) } { Michael Winter } { Nick Hodges } { Olivier Sannier (obones) } { Pelle F. S. Liljendal } { Petr Vones (pvones) } { Rik Barker (rikbarker) } { Robert Lee } { Robert Marquardt (marquardt) } { Robert Rossmair (rrossmair) } { Andreas Schmidt } { Sean Farrow (sfarrow) } { } {**************************************************************************************************} { } { Various character and string routines (searching, testing and transforming) } { } {**************************************************************************************************} { } { Last modified: $Date:: 2010-09-01 21:48:55 +0200 (mer. 01 sept. 2010) $ } { Revision: $Rev:: 3321 $ } { Author: $Author:: outchy $ } { } {**************************************************************************************************} unit JclStrings; {$I jcl.inc} interface uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} {$IFDEF SUPPORTS_UNICODE} Character, {$ENDIF SUPPORTS_UNICODE} Classes, SysUtils, JclAnsiStrings, JclWideStrings, JclBase; // Exceptions type EJclStringError = class(EJclError); // Character constants and sets const // Misc. often used character definitions NativeNull = Char(#0); NativeSoh = Char(#1); NativeStx = Char(#2); NativeEtx = Char(#3); NativeEot = Char(#4); NativeEnq = Char(#5); NativeAck = Char(#6); NativeBell = Char(#7); NativeBackspace = Char(#8); NativeTab = Char(#9); NativeLineFeed = JclBase.NativeLineFeed; NativeVerticalTab = Char(#11); NativeFormFeed = Char(#12); NativeCarriageReturn = JclBase.NativeCarriageReturn; NativeCrLf = JclBase.NativeCrLf; NativeSo = Char(#14); NativeSi = Char(#15); NativeDle = Char(#16); NativeDc1 = Char(#17); NativeDc2 = Char(#18); NativeDc3 = Char(#19); NativeDc4 = Char(#20); NativeNak = Char(#21); NativeSyn = Char(#22); NativeEtb = Char(#23); NativeCan = Char(#24); NativeEm = Char(#25); NativeEndOfFile = Char(#26); NativeEscape = Char(#27); NativeFs = Char(#28); NativeGs = Char(#29); NativeRs = Char(#30); NativeUs = Char(#31); NativeSpace = Char(' '); NativeComma = Char(','); NativeBackslash = Char('\'); NativeForwardSlash = Char('/'); NativeDoubleQuote = Char('"'); NativeSingleQuote = Char(''''); NativeLineBreak = JclBase.NativeLineBreak; 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} type TCharValidator = function(const C: Char): Boolean; function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload; function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload; // 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; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload; function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload; function StrConsistsOfNumberChars(const S: string): Boolean; function StrIsDigit(const S: string): Boolean; function StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload; function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload; function StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean; // String Transformation Routines function StrCenter(const S: string; L: SizeInt; C: Char = ' '): string; function StrCharPosLower(const S: string; CharPos: SizeInt): string; function StrCharPosUpper(const S: string; CharPos: SizeInt): 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); procedure StrLowerBuff(S: PChar); procedure StrMove(var Dest: string; const Source: string; const ToIndex, FromIndex, Count: SizeInt); function StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string; function StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string; function StrProper(const S: string): string; procedure StrProperBuff(S: PChar); function StrQuote(const S: string; C: Char): string; function StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload; function StrRemoveChars(const S: string; const Chars: array of Char): string; overload; function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload; function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload; function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload; function StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload; function StrKeepChars(const S: string; const Chars: TCharValidator): string; overload; function StrKeepChars(const S: string; const Chars: array of Char): string; overload; 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: TCharValidator; Replace: Char): string; overload; function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload; function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload; function StrRepeat(const S: string; Count: SizeInt): string; function StrRepeatLength(const S: string; L: SizeInt): string; function StrReverse(const S: string): string; procedure StrReverseInPlace(var S: string); function StrSingleQuote(const S: string): string; procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload; procedure StrSkipChars(var S: PChar; const Chars: array of Char); overload; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload; function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload; function StrSmartCase(const S: string; const Delimiters: array of Char): string; overload; 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: TCharValidator): string; overload; function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload; function StrTrimCharRight(const S: string; C: Char): string; function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload; function StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload; function StrTrimQuotes(const S: string): string; function StrUpper(const S: string): string; procedure StrUpperInPlace(var S: string); procedure StrUpperBuff(S: PChar); // String Management procedure StrAddRef(var S: string); procedure StrDecRef(var S: string); function StrLength(const S: string): SizeInt; function StrRefCount(const S: string): SizeInt; // String Search and Replace Routines function StrCharCount(const S: string; C: Char): SizeInt; overload; function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload; function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload; function StrStrCount(const S, SubS: string): SizeInt; function StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt; function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt; function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; procedure StrFillChar(var S; Count: SizeInt; C: Char); function StrRepeatChar(C: Char; Count: SizeInt): string; function StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt; function StrHasPrefix(const S: string; const Prefixes: array of string): Boolean; function StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt; function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; function StrILastPos(const SubStr, S: string): SizeInt; function StrIPos(const SubStr, S: string): SizeInt; function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; function StrIsOneOf(const S: string; const List: array of string): Boolean; function StrLastPos(const SubStr, S: string): SizeInt; function StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt; function StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean; function StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt; function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; function StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; function StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt; // 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: SizeInt): string; function StrLeft(const S: string; Count: SizeInt): string; function StrMid(const S: string; Start, Count: SizeInt): string; function StrRestOf(const S: string; N: SizeInt): string; function StrRight(const S: string; Count: SizeInt): string; // Character Test Routines function CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharType(const C: Char): Word; // Character Transformation Routines function CharHex(const C: Char): Byte; function CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function CharToggleCase(const C: Char): Char; // Character Search and Replace function CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; function CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt; function CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt; function CharReplace(var S: string; const Search, Replace: Char): SizeInt; // PCharVector type PCharVector = ^PChar; function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; function PCharVectorCount(Source: PCharVector): SizeInt; procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); procedure FreePCharVector(var Dest: PCharVector); // MultiSz Routines type PMultiSz = PChar; PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz; PWideMultiSz = JclWideStrings.PWideMultiSz; TAnsiStrings = JclAnsiStrings.TJclAnsiStrings; TWideStrings = JclWideStrings.TJclWideStrings; TAnsiStringList = JclAnsiStrings.TJclAnsiStringList; TWideStringList = JclWideStrings.TJclWideStringList; function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; procedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz); function MultiSzLength(const Source: PMultiSz): SizeInt; procedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt); procedure FreeMultiSz(var Dest: PMultiSz); function MultiSzDup(const Source: PMultiSz): PMultiSz; function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} procedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} // 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 // (OF) moved to JclSysUtils // function BooleanToStr(B: Boolean): string; // AnsiString here because it is binary data function FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; Append: Boolean = False); 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); function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload; function StrWord(var S: PChar; out Word: string): Boolean; overload; function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload; function StrIdent(var S: PChar; out Ident: string): Boolean; overload; function StrToFloatSafe(const S: string): Float; function StrToIntSafe(const S: string): Integer; procedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; function ArrayOf(List: TStrings): TDynStringArray; overload; type FormatException = class(EJclError); ArgumentException = class(EJclError); ArgumentNullException = class(EJclError); ArgumentOutOfRangeException = class(EJclError); IToString = interface ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}'] function ToString: string; end; TCharDynArray = array of Char; // The TStringBuilder class is a Delphi implementation of the .NET // System.Text.StringBuilder. // It is zero based and the method that allow an TObject (Append, Insert, // AppendFormat) are limited to IToString implementors. // This class is not threadsafe. Any instance of TStringBuilder should not // be used in different threads at the same time. TJclStringBuilder = class(TInterfacedObject, IToString) private FChars: TCharDynArray; FLength: SizeInt; FMaxCapacity: SizeInt; function GetCapacity: SizeInt; procedure SetCapacity(const Value: SizeInt); function GetChars(Index: SizeInt): Char; procedure SetChars(Index: SizeInt; const Value: Char); procedure Set_Length(const Value: SizeInt); protected function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder; public constructor Create(const Value: string; Capacity: SizeInt = 16); overload; constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload; constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload; function Append(const Value: string): TJclStringBuilder; overload; function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload; function Append(Value: Boolean): TJclStringBuilder; overload; function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload; function Append(const Value: array of Char): TJclStringBuilder; overload; function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; function Append(Value: Cardinal): TJclStringBuilder; overload; function Append(Value: Integer): TJclStringBuilder; overload; function Append(Value: Double): TJclStringBuilder; overload; function Append(Value: Int64): TJclStringBuilder; overload; function Append(Obj: TObject): TJclStringBuilder; overload; function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload; function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload; function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload; function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload; function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload; function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload; function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload; function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload; function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload; function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload; function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload; function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload; function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload; function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; overload; function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder; overload; function Remove(StartIndex, Length: SizeInt): TJclStringBuilder; function EnsureCapacity(Capacity: SizeInt): SizeInt; { IToString } function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default; property Chars: TCharDynArray read FChars; property Length: SizeInt read FLength write Set_Length; property Capacity: SizeInt read GetCapacity write SetCapacity; property MaxCapacity: SizeInt read FMaxCapacity; end; {$IFDEF RTL200_UP} TStringBuilder = SysUtils.TStringBuilder; {$ELSE ~RTL200_UP} TStringBuilder = TJclStringBuilder; {$ENDIF ~RTL200_UP} // DotNetFormat() uses the .NET format style: "{argX}" function DotNetFormat(const Fmt: string; const Args: array of const): string; overload; function DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload; function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload; function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload; // TJclTabSet type TJclTabSet = class (TInterfacedObject, IToString) private FData: TObject; function GetCount: SizeInt; function GetStops(Index: SizeInt): SizeInt; function GetTabWidth: SizeInt; function GetZeroBased: Boolean; procedure SetStops(Index, Value: SizeInt); procedure SetTabWidth(Value: SizeInt); procedure SetZeroBased(Value: Boolean); protected function FindStop(Column: SizeInt): SizeInt; function InternalTabStops: TDynSizeIntArray; function InternalTabWidth: SizeInt; procedure RemoveAt(Index: SizeInt); public constructor Create; overload; constructor Create(Data: TObject); overload; constructor Create(TabWidth: SizeInt); overload; constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload; constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload; destructor Destroy; override; // cloning and referencing function Clone: TJclTabSet; function NewReference: TJclTabSet; // Tab stops manipulation function Add(Column: SizeInt): SizeInt; function Delete(Column: SizeInt): SizeInt; // Usage function Expand(const S: string): string; overload; function Expand(const S: string; Column: SizeInt): string; overload; procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); function Optimize(const S: string): string; overload; function Optimize(const S: string; Column: SizeInt): string; overload; function StartColumn: SizeInt; function TabFrom(Column: SizeInt): SizeInt; function UpdatePosition(const S: string): SizeInt; overload; function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload; function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload; { IToString } function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP} // Conversions function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload; class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC} // Properties property ActualTabWidth: SizeInt read InternalTabWidth; property Count: SizeInt read GetCount; property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default; property TabWidth: SizeInt read GetTabWidth write SetTabWidth; property ZeroBased: Boolean read GetZeroBased write SetZeroBased; end; // Formatting constants const TabSetFormatting_SurroundStopsWithBrackets = 1; TabSetFormatting_EmptyBracketsIfNoStops = 2; TabSetFormatting_NoTabStops = 4; TabSetFormatting_NoTabWidth = 8; TabSetFormatting_AutoTabWidth = 16; // common combinations TabSetFormatting_Default = 0; TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or TabSetFormatting_EmptyBracketsIfNoStops; TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth; // aliases TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth; TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops; TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default; // Tab expansion routines function StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; function StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; function StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; // Tab optimization routines function StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload; // move to JclBase? type NullReferenceException = class(EJclError) public constructor Create; overload; end; procedure StrResetLength(var S: WideString); overload; procedure StrResetLength(var S: AnsiString); overload; procedure StrResetLength(S: TJclStringBuilder); overload; {$IFDEF SUPPORTS_UNICODE_STRING} procedure StrResetLength(var S: UnicodeString); overload; {$ENDIF SUPPORTS_UNICODE_STRING} // natural comparison functions function CompareNaturalStr(const S1, S2: string): SizeInt; function CompareNaturalText(const S1, S2: string): SizeInt; {$IFNDEF SUPPORTS_UNICODE} // internal structures published to make function inlining working const MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table var StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings StrCaseMapReady: Boolean = False; // true if case map exists StrCharTypes: array [Char] of Word; {$ENDIF ~SUPPORTS_UNICODE} {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jcl.svn.sourceforge.net:443/svnroot/jcl/tags/JCL-2.2-Build3845/jcl/source/common/JclStrings.pas $'; Revision: '$Revision: 3321 $'; Date: '$Date: 2010-09-01 21:48:55 +0200 (mer. 01 sept. 2010) $'; LogPath: 'JCL\source\common'; Extra: ''; Data: nil ); {$ENDIF UNITVERSIONING} implementation uses {$IFDEF HAS_UNIT_LIBC} Libc, {$ENDIF HAS_UNIT_LIBC} {$IFDEF SUPPORTS_UNICODE} StrUtils, {$ENDIF SUPPORTS_UNICODE} JclLogic, JclResources, JclStreams, JclSynch; //=== Internal =============================================================== type TStrRec = packed record RefCount: SizeInt; Length: SizeInt; end; PStrRec = ^TStrRec; {$IFNDEF SUPPORTS_UNICODE} procedure LoadCharTypes; var CurrChar: Char; CurrType: Word; begin for CurrChar := Low(CurrChar) to High(CurrChar) do begin {$IFDEF MSWINDOWS} CurrType := 0; GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, 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} StrCharTypes[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 StrCaseMapReady 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; StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar; StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar; StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar; end; StrCaseMapReady := True; end; end; // Uppercases or Lowercases a give string depending on the // passed offset. (UpOffset or LoOffset) procedure StrCase(var Str: string; const Offset: SizeInt); var P: PChar; I, L: SizeInt; begin L := Length(Str); if L > 0 then begin UniqueString(Str); P := PChar(Str); for I := 1 to L do begin P^ := StrCaseMap[Offset + Ord(P^)]; Inc(P); end; end; end; // 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: SizeInt); var C: Char; begin if S <> nil then begin repeat C := S^; S^ := StrCaseMap[Offset + Ord(C)]; Inc(S); until C = #0; end; end; {$ENDIF ~SUPPORTS_UNICODE} function StrEndW(Str: PWideChar): PWideChar; begin Result := Str; while Result^ <> #0 do Inc(Result); end; function ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; var idx: SizeInt; begin Result := ArrayContainsChar(Chars, C, idx); end; function ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; { optimized version for sorted arrays var I, L, H: SizeInt; begin L := Low(Chars); H := High(Chars); while L <= H do begin I := (L + H) div 2; if C = Chars[I] then begin Result := True; Exit; end else if C < Chars[I] then H := I - 1 else // C > Chars[I] L := I + 1; end; Result := False; end;} begin Index := High(Chars); while (Index >= Low(Chars)) and (Chars[Index] <> C) do Dec(Index); Result := Index >= Low(Chars); end; // String Test Routines function StrIsAlpha(const S: string): Boolean; var I: SizeInt; 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: SizeInt; 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: SizeInt; 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; const Chars: TCharValidator; CheckAll: Boolean): Boolean; var I: SizeInt; begin Result := False; if CheckAll then begin // this will not work with the current definition of the validator. The validator would need to check each character // it requires against the string (which is currently not provided to the Validator). The current implementation of // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon- // sistent with the documentation and the array-based overload. for I := 1 to Length(S) do begin Result := Chars(S[I]); if not Result then Break; end; end else begin for I := 1 to Length(S) do begin Result := Chars(S[I]); if Result then Break; end; end; end; function StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; var I: SizeInt; begin if CheckAll then begin Result := True; I := High(Chars); while (I >= 0) and Result do begin Result := CharPos(S, Chars[I]) > 0; Dec(I); end; end else begin Result := False; for I := 1 to Length(S) do begin Result := ArrayContainsChar(Chars, S[I]); if Result then Break; end; end; end; function StrIsAlphaNumUnderscore(const S: string): Boolean; var I: SizeInt; 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 := Length(S) > 0; end; function StrIsDigit(const S: string): Boolean; var I: SizeInt; 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: TCharValidator): Boolean; var I: SizeInt; begin for I := 1 to Length(S) do begin Result := ValidChars(S[I]); if not Result then Exit; end; Result := Length(S) > 0; end; function StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; var I: SizeInt; begin for I := 1 to Length(S) do begin Result := ArrayContainsChar(ValidChars, S[I]); if not Result then Exit; end; Result := Length(S) > 0; end; function StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean; begin Result := StrCompare(S1, S2, CaseSensitive) = 0; end; //=== String Transformation Routines ========================================= function StrCenter(const S: string; L: SizeInt; 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: SizeInt): string; begin Result := S; if (CharPos > 0) and (CharPos <= Length(S)) then Result[CharPos] := CharLower(Result[CharPos]); end; function StrCharPosUpper(const S: string; CharPos: SizeInt): 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 := NativeDoubleQuote + S + NativeDoubleQuote; end; function StrEnsureNoPrefix(const Prefix, Text: string): string; var PrefixLen: SizeInt; 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: SizeInt; StrLength: SizeInt; 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: SizeInt; 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: SizeInt; 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; procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); const HexDigits = string('0123456789abcdefABCDEF'); var StartI, Val, N: SizeInt; begin StartI := I; N := Pos(S[I + 1], HexDigits) - 1; if N < 0 then // '\x' without hex digit following is not escape sequence Dest := Dest + '\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 > Ord(High(Char)) then raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); Dest := Dest + Char(Val); end; end; procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string); const OctDigits = string('01234567'); var StartI, Val, N: SizeInt; begin StartI := I; // 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 > Ord(High(Char)) then raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]); Dest := Dest + Char(Val); end; var I, Len: SizeInt; 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 + NativeBell; 'b': Result := Result + NativeBackspace; 'f': Result := Result + NativeFormFeed; 'n': Result := Result + NativeLineFeed; 'r': Result := Result + NativeCarriageReturn; 't': Result := Result + NativeTab; 'v': Result := Result + NativeVerticalTab; '\': Result := Result + '\'; '"': Result := Result + '"'; '''': Result := Result + ''''; // Optionally escaped '?': Result := Result + '?'; // Optionally escaped 'x': if I < Len then // Start of hex escape sequence HandleHexEscapeSeq(S, I, Len, Result) else // '\x' at end of string is not escape sequence Result := Result + '\x'; '0'..'7': // start of octal escape sequence HandleOctEscapeSeq(S, I, Len, Result); 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 SUPPORTS_UNICODE} var P: PChar; I, L: SizeInt; begin L := Length(S); if L > 0 then begin UniqueString(S); P := PChar(S); for I := 1 to L do begin P^ := Character.ToLower(P^); Inc(P); end; end; end; {$ELSE ~SUPPORTS_UNICODE} begin StrCase(S, StrLoOffset); end; {$ENDIF ~SUPPORTS_UNICODE} procedure StrLowerBuff(S: PChar); begin {$IFDEF SUPPORTS_UNICODE} if S <> nil then begin repeat S^ := Character.ToLower(S^); Inc(S); until S^ = #0; end; {$ELSE ~SUPPORTS_UNICODE} StrCaseBuff(S, StrLoOffset); {$ENDIF ~SUPPORTS_UNICODE} end; procedure StrMove(var Dest: string; const Source: string; const ToIndex, FromIndex, Count: SizeInt); 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 Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char)); end; function StrPadLeft(const S: string; Len: SizeInt; C: Char): string; var L: SizeInt; begin L := Length(S); if L < Len then Result := StringOfChar(C, Len - L) + S else Result := S; end; function StrPadRight(const S: string; Len: SizeInt; C: Char): string; var L: SizeInt; 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 Result := StrLower(S); if Result <> '' then Result[1] := UpCase(Result[1]); end; procedure StrProperBuff(S: PChar); begin if (S <> nil) and (S^ <> #0) then begin StrLowerBuff(S); S^ := CharUpper(S^); end; end; function StrQuote(const S: string; C: Char): string; var L: SizeInt; 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: TCharValidator): string; var Source, Dest: PChar; Len, Index: SizeInt; 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 Chars(Source^) then begin Dest^ := Source^; Inc(Dest); end; Inc(Source); end; SetLength(Result, Dest - PChar(Result)); end; function StrRemoveChars(const S: string; const Chars: array of Char): string; var Source, Dest: PChar; Len, Index: SizeInt; 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 ArrayContainsChar(Chars, Source^) then begin Dest^ := Source^; Inc(Dest); end; Inc(Source); end; SetLength(Result, Dest - PChar(Result)); end; function StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; var Len : SizeInt; I: SizeInt; begin Len := Length(S); I := 1; while (I <= Len) and Chars(s[I]) do Inc(I); Result := Copy (s, I, Len-I+1); end; function StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; var Len : SizeInt; I: SizeInt; begin Len := Length(S); I := 1; while (I <= Len) and ArrayContainsChar(Chars, s[I]) do Inc(I); Result := Copy (s, I, Len-I+1); end; function StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; var Len : SizeInt; begin Len := Length(S); while (Len > 0) and Chars(s[Len]) do Dec(Len); Result := Copy (s, 1, Len); end; function StrRemoveEndChars(const S: string; const Chars: array of Char): string; var Len : SizeInt; begin Len := Length(S); while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do Dec(Len); Result := Copy (s, 1, Len); end; function StrKeepChars(const S: string; const Chars: TCharValidator): string; var Source, Dest: PChar; Len, Index: SizeInt; begin Len := Length(S); SetLength(Result, Len); UniqueString(Result); Source := PChar(S); Dest := PChar(Result); for Index := 0 to Len - 1 do begin if Chars(Source^) then begin Dest^ := Source^; Inc(Dest); end; Inc(Source); end; SetLength(Result, Dest - PChar(Result)); end; function StrKeepChars(const S: string; const Chars: array of Char): string; var Source, Dest: PChar; Len, Index: SizeInt; begin Len := Length(S); SetLength(Result, Len); UniqueString(Result); Source := PChar(S); Dest := PChar(Result); for Index := 0 to Len - 1 do begin if ArrayContainsChar(Chars, Source^) then begin Dest^ := Source^; Inc(Dest); end; Inc(Source); end; SetLength(Result, Dest - PChar(Result)); end; function StrRepeat(const S: string; Count: SizeInt): string; var Len, Index: SizeInt; 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); end; end; function StrRepeatLength(const S: string; L: SizeInt): string; var Len: SizeInt; 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; procedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags); 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: SizeInt; { length of result string } C: Char; { first character of search string } IgnoreCase: Boolean; begin if Search = '' then begin if S = '' then begin S := Replace; Exit; end else raise EJclStringError.CreateRes(@RsBlankSearchString); end; if S <> '' then begin IgnoreCase := rfIgnoreCase in Flags; if IgnoreCase then SearchStr := StrUpper(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 * SizeOf(Char)); 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; function StrReplaceChar(const S: string; const Source, Replace: Char): string; var I: SizeInt; begin Result := S; for I := 1 to Length(S) do if Result[I] = Source then Result[I] := Replace; end; function StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; var I: SizeInt; begin Result := S; for I := 1 to Length(S) do if Chars(Result[I]) then Result[I] := Replace; end; function StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; var I: SizeInt; begin Result := S; for I := 1 to Length(S) do if ArrayContainsChar(Chars, Result[I]) then Result[I] := Replace; end; function StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; var I: SizeInt; begin Result := S; for I := 1 to Length(S) do if not Chars(Result[I]) then Result[I] := Replace; end; function StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; var I: SizeInt; begin Result := S; for I := 1 to Length(S) do if not ArrayContainsChar(Chars, Result[I]) then Result[I] := Replace; end; function StrReverse(const S: string): string; begin Result := S; StrReverseInplace(Result); end; procedure StrReverseInPlace(var S: string); { TODO -oahuser : Warning: This is dangerous for unicode surrogates } var P1, P2: PChar; C: Char; begin UniqueString(S); P1 := PChar(S); P2 := P1 + (Length(S) - 1); while P1 < P2 do begin C := P1^; P1^ := P2^; P2^ := C; Inc(P1); Dec(P2); end; end; function StrSingleQuote(const S: string): string; begin Result := NativeSingleQuote + S + NativeSingleQuote; end; procedure StrSkipChars(var S: PChar; const Chars: TCharValidator); begin while Chars(S^) do Inc(S); end; procedure StrSkipChars(var S: PChar; const Chars: array of Char); begin while ArrayContainsChar(Chars, S^) do Inc(S); end; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); begin while Chars(S[Index]) do Inc(Index); end; procedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); begin while ArrayContainsChar(Chars, S[Index]) do Inc(Index); end; function StrSmartCase(const S: string; const Delimiters: TCharValidator): string; var Source, Dest: PChar; Index, Len: SizeInt; InternalDelimiters: TCharValidator; begin Result := ''; if Assigned(Delimiters) then InternalDelimiters := Delimiters else InternalDelimiters := CharIsSpace; if S <> '' then begin Result := S; UniqueString(Result); Len := Length(S); Source := PChar(S); Dest := PChar(Result); Inc(Dest); for Index := 2 to Len do begin if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then Dest^ := CharUpper(Dest^); Inc(Dest); Inc(Source); end; Result[1] := CharUpper(Result[1]); end; end; function StrSmartCase(const S: string; const Delimiters: array of Char): string; var Source, Dest: PChar; Index, Len: SizeInt; begin Result := ''; if S <> '' then begin Result := S; UniqueString(Result); Len := Length(S); Source := PChar(S); Dest := PChar(Result); Inc(Dest); for Index := 2 to Len do begin if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then Dest^ := CharUpper(Dest^); Inc(Dest); Inc(Source); end; Result[1] := CharUpper(Result[1]); end; end; function StrStringToEscaped(const S: string): string; var I: SizeInt; begin Result := ''; for I := 1 to Length(S) do begin case S[I] of NativeBackspace: Result := Result + '\b'; NativeBell: Result := Result + '\a'; NativeCarriageReturn: Result := Result + '\r'; NAtiveFormFeed: Result := Result + '\f'; NativeLineFeed: Result := Result + '\n'; NativeTab: Result := Result + '\t'; NativeVerticalTab: Result := Result + '\v'; NativeBackSlash: Result := Result + '\\'; NativeDoubleQuote: Result := Result + '\"'; else // Characters < ' ' are escaped with hex sequence if S[I] < #32 then Result := Result + Format('\x%.2x', [SizeInt(S[I])]) else Result := Result + S[I]; end; end; end; function StrStripNonNumberChars(const S: string): string; var I: SizeInt; 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: SizeInt; C, L, N: SizeInt; BL, BH: Byte; S: string; begin Result := ''; if Source <> '' then begin S := Source; L := Length(S); if Odd(L) then begin S := '0' + S; Inc(L); end; Index := 1; SetLength(Result, L div 2); 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; Result[N] := Char((BH shl 4) or BL); Inc(N); end; end; end; function StrTrimCharLeft(const S: string; C: Char): string; var I, L: SizeInt; 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: TCharValidator): string; var I, L: SizeInt; begin I := 1; L := Length(S); while (I <= L) and Chars(S[I]) do Inc(I); Result := Copy(S, I, L - I + 1); end; function StrTrimCharsLeft(const S: string; const Chars: array of Char): string; var I, L: SizeInt; begin I := 1; L := Length(S); while (I <= L) and ArrayContainsChar(Chars, S[I]) do Inc(I); Result := Copy(S, I, L - I + 1); end; function StrTrimCharRight(const S: string; C: Char): string; var I: SizeInt; begin I := Length(S); while (I >= 1) and (S[I] = C) do Dec(I); Result := Copy(S, 1, I); end; function StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; var I: SizeInt; begin I := Length(S); while (I >= 1) and Chars(S[I]) do Dec(I); Result := Copy(S, 1, I); end; function StrTrimCharsRight(const S: string; const Chars: array of Char): string; var I: SizeInt; begin I := Length(S); while (I >= 1) and ArrayContainsChar(Chars, S[I]) do Dec(I); Result := Copy(S, 1, I); end; function StrTrimQuotes(const S: string): string; var First, Last: Char; L: SizeInt; begin L := Length(S); if L > 1 then begin First := S[1]; Last := S[L]; if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) 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 SUPPORTS_UNICODE} var P: PChar; I, L: SizeInt; begin L := Length(S); if L > 0 then begin UniqueString(S); P := PChar(S); for I := 1 to L do begin P^ := Character.ToUpper(P^); Inc(P); end; end; end; {$ELSE ~SUPPORTS_UNICODE} begin StrCase(S, StrUpOffset); end; {$ENDIF ~SUPPORTS_UNICODE} procedure StrUpperBuff(S: PChar); begin {$IFDEF SUPPORTS_UNICODE} if S <> nil then begin repeat S^ := Character.ToUpper(S^); Inc(S); until S^ = #0; end; {$ELSE ~SUPPORTS_UNICODE} StrCaseBuff(S, StrUpOffset); {$ENDIF ~SUPPORTS_UNICODE} end; //=== String Management ====================================================== procedure StrAddRef(var S: string); var P: PStrRec; begin P := Pointer(S); if P <> nil then begin Dec(P); if P^.RefCount = -1 then UniqueString(S) else LockedInc(P^.RefCount); end; end; procedure StrDecRef(var S: string); var P: PStrRec; begin P := Pointer(S); if P <> nil then begin Dec(P); case P^.RefCount of -1, 0: { nothing } ; 1: begin Finalize(S); Pointer(S) := nil; end; else LockedDec(P^.RefCount); end; end; end; function StrLength(const S: string): SizeInt; var P: PStrRec; begin Result := 0; P := Pointer(S); if P <> nil then begin Dec(P); Result := P^.Length and (not $80000000 shr 1); end; end; function StrRefCount(const S: string): SizeInt; var P: PStrRec; begin Result := 0; P := Pointer(S); if P <> nil then begin Dec(P); Result := P^.RefCount; end; end; procedure StrResetLength(var S: WideString); var I: SizeInt; begin for I := 0 to Length(S) - 1 do if S[I + 1] = #0 then begin SetLength(S, I); Exit; end; end; procedure StrResetLength(var S: AnsiString); var I: SizeInt; begin for I := 0 to Length(S) - 1 do if S[I + 1] = #0 then begin SetLength(S, I); Exit; end; end; procedure StrResetLength(S: TJclStringBuilder); var I: SizeInt; begin if S <> nil then for I := 0 to S.Length - 1 do if S[I] = #0 then begin S.Length := I; Exit; end; end; {$IFDEF SUPPORTS_UNICODE_STRING} procedure StrResetLength(var S: UnicodeString); var I: SizeInt; begin for I := 0 to Length(S) - 1 do if S[I + 1] = #0 then begin SetLength(S, I); Exit; end; end; {$ENDIF SUPPORTS_UNICODE_STRING} //=== String Search and Replace Routines ===================================== function StrCharCount(const S: string; C: Char): SizeInt; var I: SizeInt; begin Result := 0; for I := 1 to Length(S) do if S[I] = C then Inc(Result); end; function StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; var I: SizeInt; begin Result := 0; for I := 1 to Length(S) do if Chars(S[I]) then Inc(Result); end; function StrCharsCount(const S: string; const Chars: array of Char): SizeInt; var I: SizeInt; begin Result := 0; for I := 1 to Length(S) do if ArrayContainsChar(Chars, S[I]) then Inc(Result); end; function StrStrCount(const S, SubS: string): SizeInt; var I: SizeInt; 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; (* { 1} Test(StrCompareRange('', '', 1, 5), 0); { 2} Test(StrCompareRange('A', '', 1, 5), -1); { 3} Test(StrCompareRange('AB', '', 1, 5), -1); { 4} Test(StrCompareRange('ABC', '', 1, 5), -1); { 5} Test(StrCompareRange('', 'A', 1, 5), -1); { 6} Test(StrCompareRange('', 'AB', 1, 5), -1); { 7} Test(StrCompareRange('', 'ABC', 1, 5), -1); { 8} Test(StrCompareRange('A', 'a', 1, 5), -2); { 9} Test(StrCompareRange('A', 'a', 1, 1), -32); {10} Test(StrCompareRange('aA', 'aB', 1, 1), 0); {11} Test(StrCompareRange('aA', 'aB', 1, 2), -1); {12} Test(StrCompareRange('aB', 'aA', 1, 2), 1); {13} Test(StrCompareRange('aA', 'aa', 1, 2), -32); {14} Test(StrCompareRange('aa', 'aA', 1, 2), 32); {15} Test(StrCompareRange('', '', 1, 0), 0); {16} Test(StrCompareRange('A', 'A', 1, 0), -2); {17} Test(StrCompareRange('Aa', 'A', 1, 0), -2); {18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0); {19} Test(StrCompareRange('Aa', 'A', 1, 2), 0); {20} Test(StrCompareRange('Ba', 'A', 1, 2), 1); *) function StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; var Len1, Len2: SizeInt; I: SizeInt; C1, C2: Char; begin if Pointer(S1) = Pointer(S2) then begin if (Count <= 0) and (S1 <> '') then Result := -2 // no work else Result := 0; end else if (S1 = '') or (S2 = '') then Result := -1 // null string else if Count <= 0 then Result := -2 // no work else begin Len1 := Length(S1); Len2 := Length(S2); if (Index - 1) + Count > Len1 then Result := -2 else begin if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it Count := Len2 - (Index - 1); if CaseSensitive then begin for I := 0 to Count - 1 do begin C1 := S1[Index + I]; C2 := S2[Index + I]; if C1 <> C2 then begin Result := Ord(C1) - Ord(C2); Exit; end; end; end else begin for I := 0 to Count - 1 do begin C1 := S1[Index + I]; C2 := S2[Index + I]; if C1 <> C2 then begin C1 := CharLower(C1); C2 := CharLower(C2); if C1 <> C2 then begin Result := Ord(C1) - Ord(C2); Exit; end; end; end; end; Result := 0; end; end; end; function StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt; var Len1, Len2: SizeInt; begin if Pointer(S1) = Pointer(S2) then Result := 0 else begin Len1 := Length(S1); Len2 := Length(S2); Result := Len1 - Len2; if Result = 0 then Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive); end; end; function StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt; begin Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive); end; procedure StrFillChar(var S; Count: SizeInt; C: Char); {$IFDEF SUPPORTS_UNICODE} asm // 32 --> EAX S // EDX Count // ECX C // 64 --> RCX S // RDX Count // R8 C {$IFDEF CPU32} DEC EDX JS @@Leave @@Loop: MOV [EAX], CX ADD EAX, 2 DEC EDX JNS @@Loop {$ENDIF CPU32} {$IFDEF CPU64} DEC RDX MOV RAX,RCX MOV RCX,R8 JS @@Leave @@Loop: MOV [RAX], CX ADD RAX, 2 DEC RDX JNS @@Loop {$ENDIF CPU64} @@Leave: end; {$ELSE ~SUPPORTS_UNICODE} begin if Count > 0 then FillChar(S, Count, C); end; {$ENDIF ~SUPPORTS_UNICODE} function StrRepeatChar(C: Char; Count: SizeInt): string; begin SetLength(Result, Count); if Count > 0 then StrFillChar(Result[1], Count, C); end; function StrFind(const Substr, S: string; const Index: SizeInt): SizeInt; var pos: SizeInt; begin if (SubStr <> '') and (S <> '') then begin pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1)); if pos = 0 then Result := 0 else Result := Index + Pos - 1; end else Result := 0; end; 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; CaseSensitive: Boolean): SizeInt; var I: SizeInt; begin Result := -1; for I := Low(List) to High(List) do begin if StrCompare(S, List[I], CaseSensitive) = 0 then begin Result := I; Break; end; end; end; function StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean; begin Result := StrIPrefixIndex(S, Prefixes) > -1; end; function StrILastPos(const SubStr, S: string): SizeInt; begin Result := StrLastPos(StrUpper(SubStr), StrUpper(S)); end; function StrIPos(const SubStr, S: string): SizeInt; begin Result := Pos(StrUpper(SubStr), StrUpper(S)); end; function StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt; var I: SizeInt; Test: string; begin Result := -1; for I := Low(Prefixes) to High(Prefixes) do begin Test := StrLeft(S, Length(Prefixes[I])); if CompareText(Test, Prefixes[I]) = 0 then begin Result := I; Break; end; end; 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): SizeInt; var Last, Current: PChar; begin Result := 0; Last := nil; Current := PChar(S); while (Current <> nil) and (Current^ <> #0) do begin Current := StrPos(PChar(Current), PChar(SubStr)); if Current <> nil then begin Last := Current; Inc(Current); end; end; if Last <> nil then Result := Abs(PChar(S) - Last) + 1; end; // IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*) // (*) acts like (?) function StrMatch(const Substr, S: string; Index: SizeInt): SizeInt; var SI, SubI, SLen, SubLen: SizeInt; SubC: Char; begin SLen := Length(S); SubLen := Length(Substr); Result := 0; if (Index > SLen) or (SubLen = 0) then Exit; while Index <= SLen do begin SubI := 1; SI := Index; while (SI <= SLen) and (SubI <= SubLen) do begin SubC := Substr[SubI]; if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then begin Inc(SI); Inc(SubI); end else Break; end; if SubI > SubLen then begin Result := Index; Break; end; Inc(Index); end; end; // Derived from "Like" by Michael Winter function StrMatches(const Substr, S: string; const Index: SizeInt): Boolean; 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; if (Index <= 0) or (Index > Length(S)) then raise EJclStringError.CreateRes(@RsArgumentOutOfRange); 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; function StrNPos(const S, SubStr: string; N: SizeInt): SizeInt; var I, P: SizeInt; 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: SizeInt): SizeInt; var I, P: SizeInt; 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): SizeInt; var I: SizeInt; Test: string; begin Result := -1; for I := Low(Prefixes) to High(Prefixes) do begin Test := StrLeft(S, Length(Prefixes[I])); if CompareStr(Test, Prefixes[I]) = 0 then begin Result := I; Break; end; end; end; function StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt; var SP, SPI, SubP: PChar; SLen: SizeInt; begin SLen := Length(S); if Index <= SLen then begin SP := PChar(S); SubP := PChar(Substr); SPI := SP; Inc(SPI, Index); Dec(SPI); SPI := StrPos(SPI, SubP); if SPI <> nil then Result := SPI - SP + 1 else Result := 0; end else Result := 0; end; //=== String Extraction ====================================================== function StrAfter(const SubStr, S: string): string; var P: SizeInt; 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: SizeInt; 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: SizeInt; L: SizeInt; 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: SizeInt): string; begin Result := Copy(S, 1, Length(S) - N); end; function StrLeft(const S: string; Count: SizeInt): string; begin Result := Copy(S, 1, Count); end; function StrMid(const S: string; Start, Count: SizeInt): string; begin Result := Copy(S, Start, Count); end; function StrRestOf(const S: string; N: SizeInt): string; begin Result := Copy(S, N, (Length(S) - N + 1)); end; function StrRight(const S: string; Count: SizeInt): 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 SUPPORTS_UNICODE} Result := Character.IsLetter(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_ALPHA) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsAlphaNum(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsLetterOrDigit(C); {$ELSE ~SUPPORTS_UNICODE} Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0); {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsBlank(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000); {$ELSE ~SUPPORTS_UNICODE} Result := ((StrCharTypes[C] and C1_BLANK) <> 0); {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsControl(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsControl(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_CNTRL) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsDelete(const C: Char): Boolean; begin Result := (C = #8); end; function CharIsDigit(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsDigit(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_DIGIT) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsFracDigit(const C: Char): Boolean; begin Result := (C = '.') or CharIsDigit(C); end; function CharIsHexDigit(const C: Char): Boolean; begin case C of 'A'..'F', 'a'..'f': Result := True; else Result := CharIsDigit(C); end; end; function CharIsLower(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsLower(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_LOWER) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsNumberChar(const C: Char): Boolean; begin Result := CharIsDigit(C) or (C = '+') or (C = '-') or (C = {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator); end; function CharIsNumber(const C: Char): Boolean; begin Result := CharIsDigit(C) or (C = {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator); end; function CharIsPrintable(const C: Char): Boolean; begin Result := not CharIsControl(C); end; function CharIsPunctuation(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsPunctuation(C); {$ELSE ~SUPPORTS_UNICODE} Result := ((StrCharTypes[C] and C1_PUNCT) <> 0); {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsReturn(const C: Char): Boolean; begin Result := (C = NativeLineFeed) or (C = NativeCarriageReturn); end; function CharIsSpace(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsWhiteSpace(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_SPACE) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsUpper(const C: Char): Boolean; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.IsUpper(C); {$ELSE ~SUPPORTS_UNICODE} Result := (StrCharTypes[C] and C1_UPPER) <> 0; {$ENDIF ~SUPPORTS_UNICODE} end; function CharIsValidIdentifierLetter(const C: Char): Boolean; begin case C of {$IFDEF SUPPORTS_UNICODE} // from XML specifications #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D, #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF, #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs? #$00B7, #$0300..#$036F, #$203F..#$2040, {$ENDIF SUPPORTS_UNICODE} '0'..'9', 'A'..'Z', 'a'..'z', '_': Result := True; else Result := False; end; end; function CharIsWhiteSpace(const C: Char): Boolean; begin case C of NativeTab, NativeLineFeed, NativeVerticalTab, NativeFormFeed, NativeCarriageReturn, NativeSpace: Result := True; else Result := False; end; end; function CharIsWildcard(const C: Char): Boolean; begin case C of '*', '?': Result := True; else Result := False; end; end; function CharType(const C: Char): Word; begin {$IFDEF SUPPORTS_UNICODE} GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result); {$ELSE ~SUPPORTS_UNICODE} Result := StrCharTypes[C]; {$ENDIF ~SUPPORTS_UNICODE} end; //=== PCharVector ============================================================ function StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector; var I: SizeInt; 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): SizeInt; begin Result := 0; if Source <> nil then begin while Source^ <> nil do begin Inc(Source); Inc(Result); end; end; end; procedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector); var I, Count: SizeInt; 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: SizeInt; 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; //=== Character Transformation Routines ====================================== function CharHex(const C: Char): Byte; begin case C of '0'..'9': Result := Ord(C) - Ord('0'); 'a'..'f': Result := Ord(C) - Ord('a') + 10; 'A'..'F': Result := Ord(C) - Ord('A') + 10; else Result := $FF; end; end; function CharLower(const C: Char): Char; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.ToLower(C); {$ELSE ~SUPPORTS_UNICODE} Result := StrCaseMap[Ord(C) + StrLoOffset]; {$ENDIF ~SUPPORTS_UNICODE} end; function CharToggleCase(const C: Char): Char; begin {$IFDEF SUPPORTS_UNICODE} if CharIsLower(C) then Result := CharUpper(C) else if CharIsUpper(C) then Result := CharLower(C) else Result := C; {$ELSE ~SUPPORTS_UNICODE} Result := StrCaseMap[Ord(C) + StrReOffset]; {$ENDIF ~SUPPORTS_UNICODE} end; function CharUpper(const C: Char): Char; begin {$IFDEF SUPPORTS_UNICODE} Result := Character.ToUpper(C); {$ELSE ~SUPPORTS_UNICODE} Result := StrCaseMap[Ord(C) + StrUpOffset]; {$ENDIF ~SUPPORTS_UNICODE} end; //=== Character Search and Replace =========================================== function CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt; 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: SizeInt): SizeInt; 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: SizeInt): SizeInt; begin if (Index > 0) and (Index <= Length(S)) then begin C := CharUpper(C); for Result := Index to Length(S) do if CharUpper(S[Result]) = C then Exit; end; Result := 0; end; function CharReplace(var S: string; const Search, Replace: Char): SizeInt; var P: PChar; Index, Len: SizeInt; 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; //=== MultiSz ================================================================ function StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz; var I, TotalLength: SizeInt; 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): SizeInt; 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: SizeInt); 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: SizeInt; begin if Source <> nil then begin Len := MultiSzLength(Source); Result := nil; AllocateMultiSz(Result, Len); Move(Source^, Result^, Len * SizeOf(Char)); end else Result := nil; end; function AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz; begin Result := JclAnsiStrings.StringsToMultiSz(Dest, Source); end; procedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); begin JclAnsiStrings.MultiSzToStrings(Dest, Source); end; function AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; begin Result := JclAnsiStrings.MultiSzLength(Source); end; procedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); begin JclAnsiStrings.AllocateMultiSz(Dest, Len); end; procedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); begin JclAnsiStrings.FreeMultiSz(Dest); end; function AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; begin Result := JclAnsiStrings.MultiSzDup(Source); end; function WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz; begin Result := JclWideStrings.StringsToMultiSz(Dest, Source); end; procedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); begin JclWideStrings.MultiSzToStrings(Dest, Source); end; function WideMultiSzLength(const Source: PWideMultiSz): SizeInt; begin Result := JclWideStrings.MultiSzLength(Source); end; procedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); begin JclWideStrings.AllocateMultiSz(Dest, Len); end; procedure FreeWideMultiSz(var Dest: PWideMultiSz); begin JclWideStrings.FreeMultiSz(Dest); end; function WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; begin Result := JclWideStrings.MultiSzDup(Source); end; //=== TStrings Manipulation ================================================== procedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True); var I, L: SizeInt; 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: SizeInt; 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: SizeInt; 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: SizeInt; 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: SizeInt; 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: SizeInt; 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 FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; var fs: TFileStream; Len: SizeInt; begin fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Len := fs.Size; SetLength(Result, Len); if Len > 0 then fs.ReadBuffer(Result[1], Len); finally fs.Free; end; end; procedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF}; Append: Boolean); var FS: TFileStream; Len: SizeInt; begin if Append and FileExists(filename) then FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite) else FS := TFileStream.Create(FileName, fmCreate); try if Append then FS.Seek(0, soEnd); // faster than .Position := .Size Len := Length(Contents); if Len > 0 then FS.WriteBuffer(Contents[1], Len); finally FS.Free; end; end; function StrToken(var S: string; Separator: Char): string; var I: SizeInt; 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; 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 := JclStrings.StrWord(Start, Token); if Token <> '' then List.Add(Token); until Done; finally List.EndUpdate; end; end; function StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; var Start: SizeInt; C: Char; begin Word := ''; if (S = '') then begin Result := True; Exit; end; Start := Index; Result := False; while True do begin C := S[Index]; case C of #0: begin if Start <> 0 then Word := Copy(S, Start, Index - Start); Result := True; Exit; end; NativeSpace, NativeLineFeed, NativeCarriageReturn: begin if Start <> 0 then begin Word := Copy(S, Start, Index - Start); Exit; end else begin while CharIsWhiteSpace(C) do begin Inc(Index); C := S[Index]; end; end; end; else if Start = 0 then Start := Index; Inc(Index); end; 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; NativeSpace, NativeLineFeed, NativeCarriageReturn: begin if Start <> nil then begin SetString(Word, Start, S - Start); Exit; end else while CharIsWhiteSpace(S^) do Inc(S); end; else if Start = nil then Start := S; Inc(S); end; end; end; function StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; var Start: SizeInt; C: Char; begin Ident := ''; if (S = '') then begin Result := True; Exit; end; Start := Index; Result := False; while True do begin C := S[Index]; if CharIsValidIdentifierLetter(C) then begin if Start = 0 then Start := Index; end else if C = #0 then begin if Start <> 0 then Ident := Copy(S, Start, Index - Start); Result := True; Exit; end else begin if Start <> 0 then begin Ident := Copy(S, Start, Index - Start); Exit; end; end; Inc(Index); end; end; function StrIdent(var S: PChar; out Ident: string): Boolean; var Start: PChar; C: Char; begin Ident := ''; if S = nil then begin Result := True; Exit; end; Start := nil; Result := False; while True do begin C := S^; if CharIsValidIdentifierLetter(C) then begin if Start = nil then Start := S; end else if C = #0 then begin if Start <> nil then SetString(Ident, Start, S - Start); Result := True; Exit; end else begin if Start <> nil then begin SetString(Ident, Start, S - Start); Exit; end end; Inc(S); end; end; 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: SizeInt; SwapSeparators, IsNegative: Boolean; DecSep, ThouSep, C: Char; begin DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator; ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator; Temp := S; SwapSeparators := False; IsNegative := False; J := 0; for I := 1 to Length(Temp) do begin C := Temp[I]; if C = '-' then IsNegative := not IsNegative else if (C <> ' ') and (C <> '(') and (C <> '+') 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 for I := 1 to Length(Temp) do if Temp[I] = DecSep then Temp[I] := ThouSep else if Temp[I] = ThouSep then Temp[I] := DecSep; end; Temp := StrKeepChars(Temp, CharIsNumber); 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: SizeInt; var Index: SizeInt; var Count: SizeInt); overload; begin Index := Max(1, Min(Index, StrLen + 1)); Count := Max(0, Min(Count, StrLen + 1 - Index)); end; function ArrayOf(List: TStrings): TDynStringArray; var I: SizeInt; 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; const BoolToStr: array [Boolean] of string = ('false', 'true'); type TInterfacedObjectAccess = class(TInterfacedObject); procedure MoveChar(const Source; var Dest; Count: SizeInt); begin if Count > 0 then Move(Source, Dest, Count * SizeOf(Char)); end; function DotNetFormat(const Fmt: string; const Arg0: Variant): string; begin Result := DotNetFormat(Fmt, [Arg0]); end; function DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; begin Result := DotNetFormat(Fmt, [Arg0, Arg1]); end; function DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; begin Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]); end; function DotNetFormat(const Fmt: string; const Args: array of const): string; var F, P: PChar; Len, Capacity, Count: SizeInt; Index, ErrorCode: SizeInt; S: string; procedure Grow(Count: SizeInt); begin if Len + Count > Capacity then begin Capacity := Capacity * 5 div 3 + Count; SetLength(Result, Capacity); end; end; function InheritsFrom(AClass: TClass; const ClassName: string): Boolean; begin Result := True; while AClass <> nil do begin if CompareText(AClass.ClassName, ClassName) = 0 then Exit; AClass := AClass.ClassParent; end; Result := False; end; function GetStringOf(const V: TVarData; Index: SizeInt): string; overload; begin case V.VType of varEmpty, varNull: raise ArgumentNullException.CreateRes(@RsArgumentIsNull); varSmallInt: Result := IntToStr(V.VSmallInt); varInteger: Result := IntToStr(V.VInteger); varSingle: Result := FloatToStr(V.VSingle); varDouble: Result := FloatToStr(V.VDouble); varCurrency: Result := CurrToStr(V.VCurrency); varDate: Result := DateTimeToStr(V.VDate); varOleStr: Result := V.VOleStr; varBoolean: Result := BoolToStr[V.VBoolean <> False]; varByte: Result := IntToStr(V.VByte); varWord: Result := IntToStr(V.VWord); varShortInt: Result := IntToStr(V.VShortInt); varLongWord: Result := IntToStr(V.VLongWord); varInt64: Result := IntToStr(V.VInt64); varString: Result := string(V.VString); {$IFDEF SUPPORTS_UNICODE_STRING} varUString: Result := string(V.VUString); {$ENDIF SUPPORTS_UNICODE_STRING} {varArray, varDispatch, varError, varUnknown, varAny, varByRef:} else raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); end; end; function GetStringOf(Index: SizeInt): string; overload; var V: TVarRec; Intf: IToString; begin V := Args[Index]; if (V.VInteger = 0) and (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency, vtInterface, vtInt64]) then raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]); case V.VType of vtInteger: Result := IntToStr(V.VInteger); vtBoolean: Result := BoolToStr[V.VBoolean]; vtChar: Result := string(AnsiString(V.VChar)); vtExtended: Result := FloatToStr(V.VExtended^); vtString: Result := string(V.VString^); vtPointer: Result := IntToHex(TJclAddr(V.VPointer), 8); vtPChar: Result := string(AnsiString(V.VPChar)); vtObject: if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then begin Result := Intf.ToString; Pointer(Intf) := nil; // do not release the object // undo the RefCount change Dec(TInterfacedObjectAccess(V.VObject).FRefCount); end else if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then Result := Intf.ToString else raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); vtClass: Result := V.VClass.ClassName; vtWideChar: Result := V.VWideChar; vtPWideChar: Result := V.VPWideChar; vtAnsiString: Result := string(V.VAnsiString); vtCurrency: Result := CurrToStr(V.VCurrency^); vtVariant: Result := GetStringOf(TVarData(V.VVariant^), Index); vtInterface: if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then Result := IToString(Intf).ToString else raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); vtWideString: Result := WideString(V.VWideString); vtInt64: Result := IntToStr(V.VInt64^); {$IFDEF SUPPORTS_UNICODE_STRING} vtUnicodeString: Result := UnicodeString(V.VUnicodeString); {$ENDIF SUPPORTS_UNICODE_STRING} else raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]); end; end; begin if Length(Args) = 0 then begin Result := Fmt; Exit; end; Len := 0; Capacity := Length(Fmt); SetLength(Result, Capacity); if Capacity = 0 then raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat); P := Pointer(Fmt); F := P; while True do begin if (P[0] = #0) or (P[0] = '{') then begin Count := P - F; Inc(P); if (P[-1] <> #0) and (P[0] = '{') then Inc(Count); // include '{' if Count > 0 then begin Grow(Count); MoveChar(F[0], Result[Len + 1], Count); Inc(Len, Count); end; if P[-1] = #0 then Break; if P[0] <> '{' then begin F := P; Inc(P); while (P[0] <> #0) and (P[0] <> '}') do Inc(P); SetString(S, F, P - F); Val(S, Index, ErrorCode); if ErrorCode <> 0 then raise FormatException.CreateRes(@RsFormatException); if (Index < 0) or (Index > High(Args)) then raise FormatException.CreateRes(@RsFormatException); S := GetStringOf(Index); if S <> '' then begin Grow(Length(S)); MoveChar(S[1], Result[Len + 1], Length(S)); Inc(Len, Length(S)); end; if P[0] = #0 then Break; end; F := P + 1; end else if (P[0] = '}') and (P[1] = '}') then begin Count := P - F + 1; Inc(P); // skip next '}' Grow(Count); MoveChar(F[0], Result[Len + 1], Count); Inc(Len, Count); F := P + 1; end; Inc(P); end; SetLength(Result, Len); end; //=== { TJclStringBuilder } ===================================================== constructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt); begin inherited Create; SetLength(FChars, Capacity); FMaxCapacity := MaxCapacity; end; constructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt); begin Create(Capacity); Append(Value); end; constructor TJclStringBuilder.Create(const Value: string; StartIndex, Length, Capacity: SizeInt); begin Create(Capacity); Append(Value, StartIndex + 1, Length); end; function TJclStringBuilder.ToString: string; begin if FLength > 0 then SetString(Result, PChar(@FChars[0]), FLength) else Result := ''; end; function TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt; begin if System.Length(FChars) < Capacity then SetCapacity(Capacity); Result := System.Length(FChars); end; procedure TJclStringBuilder.SetCapacity(const Value: SizeInt); begin if Value <> System.Length(FChars) then begin SetLength(FChars, Value); if Value < FLength then FLength := Value; end; end; function TJclStringBuilder.GetChars(Index: SizeInt): Char; begin Result := FChars[Index]; end; procedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char); begin FChars[Index] := Value; end; procedure TJclStringBuilder.Set_Length(const Value: SizeInt); begin FLength := Value; end; function TJclStringBuilder.GetCapacity: SizeInt; begin Result := System.Length(FChars); end; function TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder; var Capacity: SizeInt; begin if (Count > 0) and (RepeatCount > 0) then begin repeat Capacity := System.Length(FChars); if Capacity + Count > MaxCapacity then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if Capacity < FLength + Count then SetLength(FChars, Capacity * 5 div 3 + Count); if Count = 1 then FChars[FLength] := Value[0] else MoveChar(Value[0], FChars[FLength], Count); Inc(FLength, Count); Dec(RepeatCount); until RepeatCount <= 0; end; Result := Self; end; function TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count, RepeatCount: SizeInt): TJclStringBuilder; var Capacity: SizeInt; begin if (Index < 0) or (Index > FLength) then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if Index = FLength then AppendPChar(Value, Count, RepeatCount) else if (Count > 0) and (RepeatCount > 0) then begin repeat Capacity := System.Length(FChars); if Capacity + Count > MaxCapacity then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if Capacity < FLength + Count then SetLength(FChars, Capacity * 5 div 3 + Count); MoveChar(FChars[Index], FChars[Index + Count], FLength - Index); if Count = 1 then FChars[Index] := Value[0] else MoveChar(Value[0], FChars[Index], Count); Inc(FLength, Count); Dec(RepeatCount); Inc(Index, Count); // little optimization until RepeatCount <= 0; end; Result := Self; end; function TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if Len > 0 then AppendPChar(@Value[0], Len); Result := Self; end; function TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if (Length > 0) and (StartIndex < Len) then begin if StartIndex + Length > Len then Length := Len - StartIndex; AppendPChar(PChar(@Value[0]) + StartIndex, Length); end; Result := Self; end; function TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; begin Result := AppendPChar(@Value, 1, RepeatCount); end; function TJclStringBuilder.Append(const Value: string): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if Len > 0 then AppendPChar(Pointer(Value), Len); Result := Self; end; function TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if (Length > 0) and (StartIndex < Len) then begin if StartIndex + Length > Len then Length := Len - StartIndex; AppendPChar(PChar(Pointer(Value)) + StartIndex, Length); end; Result := Self; end; function TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder; begin Result := Append(BoolToStr[Value]); end; function TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder; begin Result := Append(IntToStr(Value)); end; function TJclStringBuilder.Append(Value: Integer): TJclStringBuilder; begin Result := Append(IntToStr(Value)); end; function TJclStringBuilder.Append(Value: Double): TJclStringBuilder; begin Result := Append(FloatToStr(Value)); end; function TJclStringBuilder.Append(Value: Int64): TJclStringBuilder; begin Result := Append(IntToStr(Value)); end; function TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder; begin Result := Append(DotNetFormat('{0}', [Obj])); end; function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; begin Result := Append(DotNetFormat(Fmt, [Arg0])); end; function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; begin Result := Append(DotNetFormat(Fmt, [Arg0, Arg1])); end; function TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; begin Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2])); end; function TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; begin Result := Append(DotNetFormat(Fmt, Args)); end; function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if Len > 0 then InsertPChar(Index, @Value[0], Len); Result := Self; end; function TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if Len > 0 then InsertPChar(Index, Pointer(Value), Len, Count); Result := Self; end; function TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; begin Result := Insert(Index, BoolToStr[Value]); end; function TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; var Len: SizeInt; begin Len := System.Length(Value); if (Length > 0) and (StartIndex < Len) then begin if StartIndex + Length > Len then Length := Len - StartIndex; InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length); end; Result := Self; end; function TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder; begin Result := Insert(Index, FloatToStr(Value)); end; function TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; begin Result := Insert(Index, IntToStr(Value)); end; function TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; begin Result := Insert(Index, IntToStr(Value)); end; function TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; begin Result := Insert(Index, IntToStr(Value)); end; function TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; begin Result := Insert(Index, Format('{0}', [Obj])); end; function TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder; begin if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if Length > 0 then begin MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length)); Dec(FLength, Length); end; Result := Self; end; function TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex, Count: SizeInt): TJclStringBuilder; var I: SizeInt; begin if Count = -1 then Count := FLength; if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if (Count > 0) and (OldChar <> NewChar) then begin for I := StartIndex to StartIndex + Length - 1 do if FChars[I] = OldChar then FChars[I] := NewChar; end; Result := Self; end; function TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder; var I: SizeInt; Offset: SizeInt; NewLen, OldLen, Capacity: SizeInt; begin if Count = -1 then Count := FLength; if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if OldValue = '' then raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]); if (Count > 0) and (OldValue <> NewValue) then begin OldLen := System.Length(OldValue); NewLen := System.Length(NewValue); Offset := NewLen - OldLen; Capacity := System.Length(FChars); for I := StartIndex to StartIndex + Length - 1 do if FChars[I] = OldValue[1] then begin if OldLen > 1 then if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then Continue; if Offset <> 0 then begin if FLength - OldLen + NewLen > MaxCurrency then raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); if Capacity < FLength + Offset then begin Capacity := Capacity * 5 div 3 + Offset; SetLength(FChars, Capacity); end; if Offset < 0 then MoveChar(FChars[I - Offset], FChars[I], FLength - I) else MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I); Inc(FLength, Offset); end; if NewLen > 0 then begin if (OldLen = 1) and (NewLen = 1) then FChars[I] := NewValue[1] else MoveChar(NewValue[1], FChars[I], NewLen); end; end; end; Result := Self; end; function StrExpandTabs(S: string): string; begin // use an empty tab set, which will default to a tab width of 2 Result := TJclTabSet(nil).Expand(s); end; function StrExpandTabs(S: string; TabWidth: SizeInt): string; var TabSet: TJclTabSet; begin // create a tab set with no tab stops and the given tab width TabSet := TJclTabSet.Create(TabWidth); try Result := TabSet.Expand(S); finally TabSet.Free; end; end; function StrExpandTabs(S: string; TabSet: TJclTabSet): string; begin // use the provided tab set to perform the expansion Result := TabSet.Expand(S); end; function StrOptimizeTabs(S: string): string; begin // use an empty tab set, which will default to a tab width of 2 Result := TJclTabSet(nil).Optimize(s); end; function StrOptimizeTabs(S: string; TabWidth: SizeInt): string; var TabSet: TJclTabSet; begin // create a tab set with no tab stops and the given tab width TabSet := TJclTabSet.Create(TabWidth); try Result := TabSet.Optimize(S); finally TabSet.Free; end; end; function StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; begin // use the provided tab set to perform the optimization Result := TabSet.Optimize(S); end; // === { TTabSetData } =================================================== type TTabSetData = class public FStops: TDynSizeIntArray; FRealWidth: SizeInt; FRefCount: SizeInt; FWidth: SizeInt; FZeroBased: Boolean; constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); function Add(Column: SizeInt): SizeInt; function AddRef: SizeInt; procedure CalcRealWidth; function FindStop(Column: SizeInt): SizeInt; function ReleaseRef: SizeInt; procedure RemoveAt(Index: SizeInt); procedure SetStops(Index, Value: SizeInt); end; constructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); var idx: SizeInt; begin inherited Create; FRefCount := 1; for idx := 0 to High(Tabstops) do Add(Tabstops[idx]); FWidth := TabWidth; FZeroBased := ZeroBased; CalcRealWidth; end; function TTabSetData.Add(Column: SizeInt): SizeInt; var I: SizeInt; begin if Column < Ord(FZeroBased) then raise ArgumentOutOfRangeException.Create('Column'); Result := FindStop(Column); if Result < 0 then begin // the column doesn't exist; invert the result of FindStop to get the correct index position Result := not Result; // increase the tab stop array SetLength(FStops, Length(FStops) + 1); // shift rooms after the insert position for I := High(FStops) - 1 downto Result do FStops[I + 1] := FStops[I]; // add the tab stop at the correct location FStops[Result] := Column; CalcRealWidth; end else begin raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); end; end; function TTabSetData.AddRef: SizeInt; begin Result := LockedInc(FRefCount); end; procedure TTabSetData.CalcRealWidth; begin if FWidth < 1 then begin if Length(FStops) > 1 then FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))] else if Length(FStops) = 1 then FRealWidth := FStops[0] else FRealWidth := 2; end else FRealWidth := FWidth; end; function TTabSetData.FindStop(Column: SizeInt): SizeInt; begin Result := High(FStops); while (Result >= 0) and (FStops[Result] > Column) do Dec(Result); if (Result >= 0) and (FStops[Result] <> Column) then Result := not Succ(Result); end; function TTabSetData.ReleaseRef: SizeInt; begin Result := LockedDec(FRefCount); if Result <= 0 then Destroy; end; procedure TTabSetData.RemoveAt(Index: SizeInt); var I: SizeInt; begin for I := Index to High(FStops) - 1 do FStops[I] := FStops[I + 1]; SetLength(FStops, High(FStops)); CalcRealWidth; end; procedure TTabSetData.SetStops(Index, Value: SizeInt); var temp: SizeInt; begin if (Index < 0) or (Index >= Length(FStops)) then begin raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange); end else begin temp := FindStop(Value); if temp < 0 then begin // remove existing tab stop... RemoveAt(Index); // now add the new tab stop Add(Value); end else if temp <> Index then begin // new tab stop already present at another index raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed); end; end; end; //=== { TJclTabSet } ===================================================== constructor TJclTabSet.Create; begin // no tab stops, tab width set to auto Create([], True, 0); end; constructor TJclTabSet.Create(TabWidth: SizeInt); begin // no tab stops, specified tab width Create([], True, TabWidth); end; constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); begin // specified tab stops, tab width equal to distance between last two tab stops Create(Tabstops, ZeroBased, 0); end; constructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); begin inherited Create; FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth); end; constructor TJclTabSet.Create(Data: TObject); begin inherited Create; // add a reference to the data TTabSetData(Data).AddRef; // assign the data to this instance FData := TTabSetData(Data); end; destructor TJclTabSet.Destroy; begin // release the reference to the tab set data TTabSetData(FData).ReleaseRef; // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction FData := nil; // really destroy the instance inherited Destroy; end; function TJclTabSet.Add(Column: SizeInt): SizeInt; begin if Self = nil then raise NullReferenceException.Create; Result := TTabSetData(FData).Add(Column); end; function TJclTabSet.Clone: TJclTabSet; begin if Self <> nil then Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth) else Result := nil; end; function TJclTabSet.Delete(Column: SizeInt): SizeInt; begin Result := TTabSetData(FData).FindStop(Column); if Result >= 0 then TTabSetData(FData).RemoveAt(Result); end; function TJclTabSet.Expand(const S: string): string; begin Result := Expand(s, StartColumn); end; function TJclTabSet.Expand(const S: string; Column: SizeInt): string; var sb: TJclStringBuilder; head: PChar; cur: PChar; begin if Column < StartColumn then raise ArgumentOutOfRangeException.Create('Column'); sb := TJclStringBuilder.Create(Length(S)); try cur := PChar(S); while cur^ <> #0 do begin head := cur; while (cur^ <> #0) and (cur^ <> #9) do begin if CharIsReturn(cur^) then Column := StartColumn else Inc(Column); Inc(cur); end; if cur > head then sb.Append(head, 0, cur - head); if cur^ = #9 then begin sb.Append(' ', TabFrom(Column) - Column); Column := TabFrom(Column); Inc(cur); end; end; Result := sb.ToString; finally sb.Free; end; end; function TJclTabSet.FindStop(Column: SizeInt): SizeInt; begin if Self <> nil then Result := TTabSetData(FData).FindStop(Column) else Result := -1; end; class function TJclTabSet.FromString(const S: string): TJclTabSet; var cur: PChar; function ParseNumber: Integer; var head: PChar; begin StrSkipChars(cur, CharIsWhiteSpace); head := cur; while CharIsDigit(cur^) do Inc(cur); Result := -1; if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then Result := -1; end; procedure ParseStops; var openBracket, hadComma: Boolean; num: SizeInt; begin StrSkipChars(cur, CharIsWhiteSpace); openBracket := cur^ = '['; hadComma := False; if openBracket then Inc(cur); repeat num := ParseNumber; if (num < 0) and hadComma then raise EJclStringError.CreateRes(@RsTabs_StopExpected) else if num >= 0 then Result.Add(num); StrSkipChars(cur, CharIsWhiteSpace); hadComma := cur^ = ','; if hadComma then Inc(cur); until (cur^ = #0) or (cur^ = '+') or (cur^ = ']'); if hadComma then raise EJclStringError.CreateRes(@RsTabs_StopExpected) else if openBracket and (cur^ <> ']') then raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected); end; procedure ParseTabWidth; var num: SizeInt; begin StrSkipChars(cur, CharIsWhiteSpace); if cur^ = '+' then begin Inc(cur); StrSkipChars(cur, CharIsWhiteSpace); num := ParseNumber; if (num < 0) then raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected) else Result.TabWidth := num; end; end; procedure ParseZeroBasedFlag; begin StrSkipChars(cur, CharIsWhiteSpace); if cur^ = '0' then begin Inc(cur); if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then begin Result.ZeroBased := True; StrSkipChars(cur, CharIsWhiteSpace); end else Dec(cur); end; end; begin Result := TJclTabSet.Create; try Result.ZeroBased := False; cur := PChar(S); ParseZeroBasedFlag; ParseStops; ParseTabWidth; except // clean up the partially complete instance (to avoid memory leaks)... Result.Free; // ... and re-raise the exception raise; end; end; function TJclTabSet.GetCount: SizeInt; begin if Self <> nil then Result := Length(TTabSetData(FData).FStops) else Result := 0; end; function TJclTabSet.GetStops(Index: SizeInt): SizeInt; begin if Self <> nil then begin if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then begin raise EJclStringError.CreateRes(@RsArgumentOutOfRange); end else Result := TTabSetData(FData).FStops[Index]; end else begin raise EJclStringError.CreateRes(@RsArgumentOutOfRange); end; end; function TJclTabSet.GetTabWidth: SizeInt; begin if Self <> nil then Result := TTabSetData(FData).FWidth else Result := 0; end; function TJclTabSet.GetZeroBased: Boolean; begin Result := (Self = nil) or TTabSetData(FData).FZeroBased; end; procedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt); var nextTab: SizeInt; begin if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state) raise ArgumentOutOfRangeException.Create('StartColumn'); if (TargetColumn < StartColumn) then // target lies before the starting column raise ArgumentOutOfRangeException.Create('TargetColumn'); TabsNeeded := 0; repeat nextTab := TabFrom(StartColumn); if nextTab <= TargetColumn then begin Inc(TabsNeeded); StartColumn := nextTab; end; until nextTab > TargetColumn; SpacesNeeded := TargetColumn - StartColumn; end; function TJclTabSet.Optimize(const S: string): string; begin Result := Optimize(S, StartColumn); end; function TJclTabSet.Optimize(const S: string; Column: SizeInt): string; var sb: TJclStringBuilder; head: PChar; cur: PChar; tgt: SizeInt; procedure AppendOptimalWhiteSpace(Target: SizeInt); var tabCount: SizeInt; spaceCount: SizeInt; begin if cur > head then begin OptimalFillInfo(Column, Target, tabCount, spaceCount); if tabCount > 0 then sb.Append(#9, tabCount); if spaceCount > 0 then sb.Append(' ', spaceCount); end; end; begin if Column < StartColumn then raise ArgumentOutOfRangeException.Create('Column'); sb := TJclStringBuilder.Create(Length(S)); try cur := PChar(s); while cur^ <> #0 do begin // locate first whitespace character head := cur; while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do Inc(cur); // output non whitespace characters if cur > head then sb.Append(head, 0, cur - head); // advance column Inc(Column, cur - head); // initialize target column indexer tgt := Column; // locate end of whitespace sequence while CharIsWhiteSpace(cur^) do begin if CharIsReturn(cur^) then begin // append optimized whitespace sequence... AppendOptimalWhiteSpace(tgt); // ...set the column back to the start of the line... Column := StartColumn; // ...reset target column indexer... tgt := Column; // ...add the line break character... sb.Append(cur^); end else if cur^ = #9 then tgt := TabFrom(tgt) // expand the tab else Inc(tgt); // a normal whitespace; taking up 1 column Inc(cur); end; AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence... Column := tgt; // ...and memorize the column for the next iteration end; Result := sb.ToString; // convert result to a string finally sb.Free; end; end; procedure TJclTabSet.RemoveAt(Index: SizeInt); begin if Self <> nil then TTabSetData(FData).RemoveAt(Index) else raise NullReferenceException.Create; end; procedure TJclTabSet.SetStops(Index, Value: SizeInt); begin if Self <> nil then TTabSetData(FData).SetStops(Index, Value) else raise NullReferenceException.Create; end; procedure TJclTabSet.SetTabWidth(Value: SizeInt); begin if Self <> nil then begin TTabSetData(FData).FWidth := Value; TTabSetData(FData).CalcRealWidth; end else raise NullReferenceException.Create; end; procedure TJclTabSet.SetZeroBased(Value: Boolean); var shift: SizeInt; idx: SizeInt; begin if Self <> nil then begin if Value <> TTabSetData(FData).FZeroBased then begin TTabSetData(FData).FZeroBased := Value; if Value then shift := -1 else shift := 1; for idx := 0 to High(TTabSetData(FData).FStops) do TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift; end; end else raise NullReferenceException.Create; end; function TJclTabSet.InternalTabStops: TDynSizeIntArray; begin if Self <> nil then Result := TTabSetData(FData).FStops else Result := nil; end; function TJclTabSet.InternalTabWidth: SizeInt; begin if Self <> nil then Result := TTabSetData(FData).FRealWidth else Result := 2; end; function TJclTabSet.NewReference: TJclTabSet; begin if Self <> nil then Result := TJclTabSet.Create(FData) else Result := nil; end; function TJclTabSet.StartColumn: SizeInt; begin if GetZeroBased then Result := 0 else Result := 1; end; function TJclTabSet.TabFrom(Column: SizeInt): SizeInt; begin if Column < StartColumn then raise ArgumentOutOfRangeException.Create('Column'); Result := FindStop(Column); if Result < 0 then Result := not Result else Inc(Result); if Result >= GetCount then begin if GetCount > 0 then Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)] else Result := StartColumn; while Result <= Column do Inc(Result, ActualTabWidth); end else Result := TTabSetData(FData).FStops[Result]; end; function TJclTabSet.ToString: string; begin Result := ToString(TabSetFormatting_Full); end; function TJclTabSet.ToString(FormattingOptions: SizeInt): string; var sb: TJclStringBuilder; idx: SizeInt; function WantBrackets: Boolean; begin Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0; end; function EmptyBrackets: Boolean; begin Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0; end; function IncludeAutoWidth: Boolean; begin Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0; end; function IncludeTabWidth: Boolean; begin Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0; end; function IncludeStops: Boolean; begin Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0; end; begin sb := TJclStringBuilder.Create; try // output the fixed tabulation positions if requested... if IncludeStops then begin // output each individual tabulation position for idx := 0 to GetCount - 1 do begin sb.Append(TabStops[idx]); sb.Append(','); end; // remove the final comma if any tabulation positions where outputted if sb.Length <> 0 then sb.Remove(sb.Length - 1, 1); // bracket the tabulation positions if requested if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then begin sb.Insert(0, '['); sb.Append(']'); end; end; // output the tab width if requested.... if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then begin // separate the tab width from any outputted tabulation positions with a whitespace if sb.Length > 0 then sb.Append(' '); // flag tab width sb.Append('+'); // finally, output the tab width sb.Append(ActualTabWidth); end; // flag zero-based tabset by outputting a 0 (zero) as the first character. if ZeroBased then sb.Insert(0, string('0 ')); Result := StrTrimCharRight(sb.ToString, ' '); finally sb.Free; end; end; function TJclTabSet.UpdatePosition(const S: string): SizeInt; var Line: SizeInt; begin Result := StartColumn; Line := -1; UpdatePosition(S, Result, Line); end; function TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt; var Line: SizeInt; begin if Column < StartColumn then raise ArgumentOutOfRangeException.Create('Column'); Result := Column; Line := -1; UpdatePosition(S, Result, Line); end; function TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; var prevChar: Char; cur: PChar; begin if Column < StartColumn then raise ArgumentOutOfRangeException.Create('Column'); // initialize loop cur := PChar(S); // iterate until end of string (the Null-character) while cur^ <> #0 do begin // check for line-breaking characters if CharIsReturn(cur^) then begin // Column moves back all the way to the left Column := StartColumn; // If this is the first line-break character or the same line-break character, increment the Line parameter Inc(Line); // check if it's the first of a two-character line-break prevChar := cur^; Inc(cur); // if it isn't a two-character line-break, undo the previous advancement if (cur^ = prevChar) or not CharIsReturn(cur^) then Dec(cur); end else // check for tab character and expand it if cur^ = #9 then Column := TabFrom(Column) else // a normal character; increment column Inc(Column); // advance pointer Inc(cur); end; // set the result to the newly calculated column Result := Column; end; //=== { NullReferenceException } ============================================= constructor NullReferenceException.Create; begin CreateRes(@RsArg_NullReferenceException); end; function CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt; var Cur1, Len1, Cur2, Len2: SizeInt; function IsRealNumberChar(ch: Char): Boolean; begin Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+'); end; procedure NumberCompare; var IsReallyNumber: Boolean; FirstDiffBreaks: Boolean; Val1, Val2: SizeInt; begin Result := 0; IsReallyNumber := False; // count leading spaces in S1 while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do begin Dec(Result); Inc(Cur1); end; // count leading spaces in S2 (canceling them out against the ones in S1) while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do begin Inc(Result); Inc(Cur2); end; // if spaces match, or both strings are actually followed by a numeric character, continue the checks if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then begin // Check signed number if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then Result := 1 else if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then Result := -1 else Result := 0; if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then Inc(Cur1); if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then Inc(Cur2); FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0'); while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do begin IsReallyNumber := True; Val1 := StrToInt(S1[Cur1]); Val2 := StrToInt(S2[Cur2]); if (Result = 0) and (Val1 < Val2) then Result := -1 else if (Result = 0) and (Val1 > Val2) then Result := 1; if FirstDiffBreaks and (Result <> 0) then Break; Inc(Cur1); Inc(Cur2); end; if IsReallyNumber then begin if not FirstDiffBreaks then begin if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then Result := 1 else if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then Result := -1; end; end; end; end; procedure SetByCompareLength; var Remain1: SizeInt; Remain2: SizeInt; begin // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be // completely equal, or S2 could be longer) Remain1 := Len1 - Cur1 + 1; Remain2 := Len2 - Cur2 + 1; if Remain1 < 0 then Remain1 := 0; if Remain2 < 0 then Remain2 := 0; if Remain1 < Remain2 then Result := -1 else if Remain1 > Remain2 then Result := 1; end; begin Cur1 := 1; Len1 := Length(S1); Cur2 := 1; Len2 := Length(S2); Result := 0; while (Result = 0) do begin if (Cur1 > Len1) or (Cur2 > Len2) then begin SetByCompareLength; Break; end else if (Cur1 <= Len1) and (Cur2 > Len2) then Result := 1 else if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then Result := -1 else if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then Result := 1 else if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then NumberCompare else begin if CaseInsensitive then Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1) else Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1); Inc(Cur1); Inc(Cur2); end; end; end; function CompareNaturalStr(const S1, S2: string): SizeInt; overload; begin Result := CompareNatural(S1, S2, False); end; function CompareNaturalText(const S1, S2: string): SizeInt; overload; begin Result := CompareNatural(S1, S2, True); end; initialization {$IFNDEF SUPPORTS_UNICODE} LoadCharTypes; // this table first LoadCaseMap; // or this function does not work {$ENDIF ~SUPPORTS_UNICODE} {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} {$IFDEF UNITVERSIONING} finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.