1{ 2 Delphi/Kylix compatibility unit: String handling routines. 3 4 This file is part of the Free Pascal run time library. 5 Copyright (c) 1999-2005 by the Free Pascal development team 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 **********************************************************************} 15{$mode objfpc} 16{$h+} 17{$inline on} 18unit StrUtils; 19 20interface 21 22uses 23 SysUtils, Types; 24 25{ --------------------------------------------------------------------- 26 Case insensitive search/replace 27 ---------------------------------------------------------------------} 28 29Function AnsiResemblesText(const AText, AOther: string): Boolean; 30Function AnsiContainsText(const AText, ASubText: string): Boolean; 31Function AnsiStartsText(const ASubText, AText: string): Boolean; 32Function AnsiEndsText(const ASubText, AText: string): Boolean; 33Function AnsiReplaceText(const AText, AFromText, AToText: string): string;inline; 34Function AnsiMatchText(const AText: string; const AValues: array of string): Boolean;inline; 35Function AnsiIndexText(const AText: string; const AValues: array of string): Integer; 36Function StartsText(const ASubText, AText: string): Boolean; inline; 37Function EndsText(const ASubText, AText: string): Boolean; inline; 38 39function ResemblesText(const AText, AOther: string): Boolean; inline; 40function ContainsText(const AText, ASubText: string): Boolean; inline; 41function MatchText(const AText: string; const AValues: array of string): Boolean; inline; 42function IndexText(const AText: string; const AValues: array of string): Integer; inline; 43 44{ --------------------------------------------------------------------- 45 Case sensitive search/replace 46 ---------------------------------------------------------------------} 47 48Function AnsiContainsStr(const AText, ASubText: string): Boolean;inline; 49Function AnsiStartsStr(const ASubText, AText: string): Boolean; 50Function AnsiEndsStr(const ASubText, AText: string): Boolean; 51Function AnsiReplaceStr(const AText, AFromText, AToText: string): string;inline; 52Function AnsiMatchStr(const AText: string; const AValues: array of string): Boolean;inline; 53Function AnsiIndexStr(const AText: string; const AValues: array of string): Integer; 54Function StartsStr(const ASubText, AText: string): Boolean; 55Function EndsStr(const ASubText, AText: string): Boolean; 56Function MatchStr(const AText: UnicodeString; const AValues: array of UnicodeString): Boolean; 57Function MatchText(const AText: UnicodeString; const AValues: array of UnicodeString): Boolean; 58Function IndexStr(const AText: UnicodeString; const AValues: array of UnicodeString): Integer; 59Function IndexText(const AText: UnicodeString; const AValues: array of UnicodeString): Integer; 60Operator in (const AText: string; const AValues: array of string):Boolean;inline; 61Operator in (const AText: UnicodeString; const AValues: array of UnicodeString):Boolean;inline; 62 63function ContainsStr(const AText, ASubText: string): Boolean; inline; 64function MatchStr(const AText: string; const AValues: array of string): Boolean; inline; 65function IndexStr(const AText: string; const AValues: array of string): Integer; inline; 66 67{ --------------------------------------------------------------------- 68 Miscellaneous 69 ---------------------------------------------------------------------} 70 71Function DupeString(const AText: string; ACount: Integer): string; 72Function ReverseString(const AText: string): string; 73Function AnsiReverseString(const AText: AnsiString): AnsiString;inline; 74Function StuffString(const AText: string; AStart, ALength: Cardinal; const ASubText: string): string; 75Function RandomFrom(const AValues: array of string): string; overload; 76Function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string = ''): string; overload; 77function NaturalCompareText (const S1 , S2 : string ): Integer ; 78function NaturalCompareText(const Str1, Str2: string; const ADecSeparator, AThousandSeparator: Char): Integer; 79 80function SplitString(const S, Delimiters: string): TStringDynArray; 81 82{ --------------------------------------------------------------------- 83 VB emulations. 84 ---------------------------------------------------------------------} 85 86Function LeftStr(const AText: AnsiString; const ACount: SizeInt): AnsiString;inline; 87Function RightStr(const AText: AnsiString; const ACount: SizeInt): AnsiString; 88Function MidStr(const AText: AnsiString; const AStart, ACount: SizeInt): AnsiString;inline; 89Function RightBStr(const AText: AnsiString; const AByteCount: SizeInt): AnsiString;inline; 90Function MidBStr(const AText: AnsiString; const AByteStart, AByteCount: SizeInt): AnsiString;inline; 91Function AnsiLeftStr(const AText: AnsiString; const ACount: SizeInt): AnsiString;inline; 92Function AnsiRightStr(const AText: AnsiString; const ACount: SizeInt): AnsiString;inline; 93Function AnsiMidStr(const AText: AnsiString; const AStart, ACount: SizeInt): AnsiString;inline; 94Function LeftBStr(const AText: AnsiString; const AByteCount: SizeInt): AnsiString;inline; 95Function LeftStr(const AText: WideString; const ACount: SizeInt): WideString;inline; 96Function RightStr(const AText: WideString; const ACount: SizeInt): WideString; 97Function MidStr(const AText: WideString; const AStart, ACount: SizeInt): WideString;inline; 98 99{ --------------------------------------------------------------------- 100 Extended search and replace 101 ---------------------------------------------------------------------} 102 103const 104 { Default word delimiters are any character except the core alphanumerics. } 105 WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0']; 106 107resourcestring 108 SErrAmountStrings = 'Amount of search and replace strings don''t match'; 109 110type 111 TStringSearchOption = (soDown, soMatchCase, soWholeWord); 112 TStringSearchOptions = set of TStringSearchOption; 113 TStringSeachOption = TStringSearchOption; 114 115Function SearchBuf(Buf: PChar; BufLen: SizeInt; SelStart, SelLength: SizeInt; SearchString: String; Options: TStringSearchOptions): PChar; 116Function SearchBuf(Buf: PChar; BufLen: SizeInt; SelStart, SelLength: SizeInt; SearchString: String): PChar;inline; // ; Options: TStringSearchOptions = [soDown] 117Function PosEx(const SubStr, S: string; Offset: SizeUint): SizeInt; 118Function PosEx(const SubStr, S: string): SizeInt;inline; // Offset: Cardinal = 1 119Function PosEx(c:char; const S: string; Offset: SizeUint): SizeInt; 120Function PosEx(const SubStr, S: UnicodeString; Offset: SizeUint): SizeInt; 121Function PosEx(c: WideChar; const S: UnicodeString; Offset: SizeUint): SizeInt; 122Function PosEx(const SubStr, S: UnicodeString): Sizeint;inline; // Offset: Cardinal = 1 123function StringsReplace(const S: string; OldPattern, NewPattern: array of string; Flags: TReplaceFlags): string; 124 125{ --------------------------------------------------------------------- 126 Delphi compat 127 ---------------------------------------------------------------------} 128 129Function ReplaceStr(const AText, AFromText, AToText: string): string;inline; 130Function ReplaceText(const AText, AFromText, AToText: string): string;inline; 131 132 133{ --------------------------------------------------------------------- 134 Soundex Functions. 135 ---------------------------------------------------------------------} 136 137type 138 TSoundexLength = 1..MaxInt; 139 140Function Soundex(const AText: string; ALength: TSoundexLength): string; 141Function Soundex(const AText: string): string;inline; // ; ALength: TSoundexLength = 4 142 143type 144 TSoundexIntLength = 1..8; 145 146Function SoundexInt(const AText: string; ALength: TSoundexIntLength): Integer; 147Function SoundexInt(const AText: string): Integer;inline; //; ALength: TSoundexIntLength = 4 148Function DecodeSoundexInt(AValue: Integer): string; 149Function SoundexWord(const AText: string): Word; 150Function DecodeSoundexWord(AValue: Word): string; 151Function SoundexSimilar(const AText, AOther: string; ALength: TSoundexLength): Boolean;inline; 152Function SoundexSimilar(const AText, AOther: string): Boolean;inline; //; ALength: TSoundexLength = 4 153Function SoundexCompare(const AText, AOther: string; ALength: TSoundexLength): Integer;inline; 154Function SoundexCompare(const AText, AOther: string): Integer;inline; //; ALength: TSoundexLength = 4 155Function SoundexProc(const AText, AOther: string): Boolean; 156 157type 158 TCompareTextProc = Function(const AText, AOther: string): Boolean; 159 160Const 161 AnsiResemblesProc: TCompareTextProc = @SoundexProc; 162 ResemblesProc: TCompareTextProc = @SoundexProc; 163 164{ --------------------------------------------------------------------- 165 Other functions, based on RxStrUtils. 166 ---------------------------------------------------------------------} 167type 168 TRomanConversionStrictness = (rcsStrict, rcsRelaxed, rcsDontCare); 169 170resourcestring 171 SInvalidRomanNumeral = '%s is not a valid Roman numeral'; 172 173function IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean; 174function DelSpace(const S: string): string; 175function DelChars(const S: string; Chr: Char): string; 176function DelSpace1(const S: string): string; 177function Tab2Space(const S: string; Numb: Byte): string; 178function NPos(const C: string; S: string; N: Integer): SizeInt; 179 180Function RPosEx(C:char;const S : AnsiString;offs:cardinal):SizeInt; overload; 181Function RPosEx(C:Unicodechar;const S : UnicodeString;offs:cardinal):SizeInt; overload; 182Function RPosEx(Const Substr : AnsiString; Const Source : AnsiString;offs:cardinal) : SizeInt; overload; 183Function RPosEx(Const Substr : UnicodeString; Const Source : UnicodeString;offs:cardinal) : SizeInt; overload; 184Function RPos(c:char;const S : AnsiString):SizeInt; overload; 185Function RPos(c:Unicodechar;const S : UnicodeString):SizeInt; overload; 186Function RPos(Const Substr : AnsiString; Const Source : AnsiString) : SizeInt; overload; 187Function RPos(Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt; overload; 188 189function AddChar(C: Char; const S: string; N: Integer): string; 190function AddCharR(C: Char; const S: string; N: Integer): string; 191function PadLeft(const S: string; N: Integer): string;inline; 192function PadRight(const S: string; N: Integer): string;inline; 193function PadCenter(const S: string; Len: SizeInt): string; 194function Copy2Symb(const S: string; Symb: Char): string; 195function Copy2SymbDel(var S: string; Symb: Char): string; 196function Copy2Space(const S: string): string;inline; 197function Copy2SpaceDel(var S: string): string;inline; 198function AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string; 199function WordCount(const S: string; const WordDelims: TSysCharSet): SizeInt; 200function WordPosition(const N: Integer; const S: string; const WordDelims: TSysCharSet): SizeInt; 201function ExtractWord(N: Integer; const S: string; const WordDelims: TSysCharSet): string;inline; 202{$IF SIZEOF(SIZEINT)<>SIZEOF(INTEGER)} 203function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; out Pos: SizeInt): string; 204{$ENDIF} 205function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; out Pos: Integer): string; 206function ExtractDelimited(N: Integer; const S: string; const Delims: TSysCharSet): string; 207{$IF SIZEOF(SIZEINT)<>SIZEOF(INTEGER)} 208function ExtractSubstr(const S: string; var Pos: SizeInt; const Delims: TSysCharSet): string; 209{$ENDIF} 210function ExtractSubstr(const S: string; var Pos: Integer; const Delims: TSysCharSet): string; 211function IsWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean; 212function FindPart(const HelpWilds, InputStr: string): SizeInt; 213function IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean; 214function XorString(const Key, Src: ShortString): ShortString; 215function XorEncode(const Key, Source: string): string; 216function XorDecode(const Key, Source: string): string; 217function GetCmdLineArg(const Switch: string; SwitchChars: TSysCharSet): string; 218function Numb2USA(const S: string): string; 219function Hex2Dec(const S: string): Longint; 220function Hex2Dec64(const S: string): int64; 221function Dec2Numb(N: Longint; Len, Base: Byte): string; 222function Numb2Dec(S: string; Base: Byte): Longint; 223function IntToBin(Value: Longint; Digits, Spaces: Integer): string; 224function IntToBin(Value: Longint; Digits: Integer): string; 225function intToBin(Value: int64; Digits:integer): string; 226function IntToRoman(Value: Longint): string; 227function TryRomanToInt(S: String; out N: LongInt; Strictness: TRomanConversionStrictness = rcsRelaxed): Boolean; 228function RomanToInt(const S: string; Strictness: TRomanConversionStrictness = rcsRelaxed): Longint; 229function RomanToIntDef(Const S : String; const ADefault: Longint = 0; Strictness: TRomanConversionStrictness = rcsRelaxed): Longint; 230procedure BinToHex(const BinBuffer: TBytes; BinBufOffset: Integer; var HexBuffer: TBytes; HexBufOffset: Integer; Count: Integer); overload; 231procedure BinToHex(BinValue: Pointer; HexValue: PWideChar; BinBufSize: Integer); overload; 232procedure BinToHex(const BinValue; HexValue: PWideChar; BinBufSize: Integer); overload; 233procedure BinToHex(BinValue: PAnsiChar; HexValue: PAnsiChar; BinBufSize: Integer); overload; 234procedure BinToHex(BinValue: PAnsiChar; HexValue: PWideChar; BinBufSize: Integer); overload; 235procedure BinToHex(const BinValue; HexValue: PAnsiChar; BinBufSize: Integer); overload; 236procedure BinToHex(BinValue: Pointer; HexValue: PAnsiChar; BinBufSize: Integer); overload; 237function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer; 238 239const 240 DigitChars = ['0'..'9']; 241 Brackets = ['(',')','[',']','{','}']; 242 StdWordDelims = [#0..' ',',','.',';','/','\',':','''','"','`'] + Brackets; 243 StdSwitchChars = ['-','/']; 244 245function PosSet (const c:TSysCharSet;const s : ansistring ):SizeInt; 246function PosSet (const c:string;const s : ansistring ):SizeInt; 247function PosSetEx (const c:TSysCharSet;const s : ansistring;count:Integer ):SizeInt; 248function PosSetEx (const c:string;const s : ansistring;count:Integer ):SizeInt; 249 250Procedure Removeleadingchars(VAR S : AnsiString; Const CSet:TSysCharset); 251Procedure RemoveTrailingChars(VAR S : AnsiString;Const CSet:TSysCharset); 252Procedure RemovePadChars(VAR S : AnsiString;Const CSet:TSysCharset); 253 254function TrimLeftSet(const S: String;const CSet:TSysCharSet): String; 255Function TrimRightSet(const S: String;const CSet:TSysCharSet): String; 256function TrimSet(const S: String;const CSet:TSysCharSet): String; 257 258 259type 260 SizeIntArray = array of SizeInt; 261 262Function FindMatchesBoyerMooreCaseSensitive(const S,OldPattern: PChar; const SSize, OldPatternSize: SizeInt; out aMatches: SizeIntArray; const aMatchAll: Boolean) : Boolean; 263Function FindMatchesBoyerMooreCaseSensitive(const S,OldPattern: String; out aMatches: SizeIntArray; const aMatchAll: Boolean) : Boolean; 264 265Function FindMatchesBoyerMooreCaseInSensitive(const S, OldPattern: PChar; const SSize, OldPatternSize: SizeInt; out aMatches: SizeIntArray; const aMatchAll: Boolean) : Boolean; 266Function FindMatchesBoyerMooreCaseInSensitive(const S, OldPattern: String; out aMatches: SizeIntArray; const aMatchAll: Boolean) : Boolean; 267 268Type 269 TStringReplaceAlgorithm = (sraDefault, // Default algoritm as used in StringUtils. 270 sraManySmall, // Algorithm optimized for many small replacements. 271 sraBoyerMoore // Algorithm optimized for long replacements. 272 ); 273 274Function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags; out aCount : Integer; Algorithm : TStringReplaceAlgorithm = sraDefault): string; overload; 275Function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags; Algorithm : TStringReplaceAlgorithm = sraDefault): string; overload; 276{ We need these for backwards compatibility: 277 The compiler will stop searching and convert to ansistring if the widestring version of stringreplace is used. 278 They currently simply refer to sysutils, till the new mechanisms are proven to work with unicode.} 279Function StringReplace(const S, OldPattern, NewPattern: unicodestring; Flags: TReplaceFlags): unicodestring; overload; 280Function StringReplace(const S, OldPattern, NewPattern: widestring; Flags: TReplaceFlags): widestring; overload; 281 282 283Type 284 TRawByteStringArray = Array of RawByteString; 285 TUnicodeStringArray = Array of UnicodeString; 286 287Function SplitCommandLine(S : RawByteString) : TRawByteStringArray; 288Function SplitCommandLine(S : UnicodeString) : TUnicodeStringArray; 289 290 291implementation 292 293(* 294 FindMatchesBoyerMooreCaseSensitive 295 296 Finds one or many ocurrences of an ansistring in another ansistring. 297 It is case sensitive. 298 299 * Parameters: 300 S: The PChar to be searched in. (Read only). 301 OldPattern: The PChar to be searched. (Read only). 302 SSize: The size of S in Chars. (Read only). 303 OldPatternSize: The size of OldPatter in chars. (Read only). 304 aMatches: SizeInt array where match indexes are returned (zero based) (write only). 305 aMatchAll: Finds all matches, not just the first one. (Read only). 306 307 * Returns: 308 Nothing, information returned in aMatches parameter. 309 310 The function is based in the Boyer-Moore algorithm. 311*) 312 313function FindMatchesBoyerMooreCaseSensitive(const S, OldPattern: PChar; 314 const SSize, OldPatternSize: SizeInt; out aMatches: SizeIntArray; 315 const aMatchAll: Boolean) : Boolean; 316 317const 318 ALPHABET_LENGHT=256; 319 MATCHESCOUNTRESIZER=100; //Arbitrary value. Memory used = MATCHESCOUNTRESIZER * sizeof(SizeInt) 320var 321 //Stores the amount of replaces that will take place 322 MatchesCount: SizeInt; 323 //Currently allocated space for matches. 324 MatchesAllocatedLimit: SizeInt; 325type 326 AlphabetArray=array [0..ALPHABET_LENGHT-1] of SizeInt; 327 328 function Max(const a1,a2: SizeInt): SizeInt; 329 begin 330 if a1>a2 then Result:=a1 else Result:=a2; 331 end; 332 333 procedure MakeDeltaJumpTable1(out DeltaJumpTable1: AlphabetArray; const aPattern: PChar; const aPatternSize: SizeInt); 334 var 335 i: SizeInt; 336 begin 337 for i := 0 to ALPHABET_LENGHT-1 do begin 338 DeltaJumpTable1[i]:=aPatternSize; 339 end; 340 //Last char do not enter in the equation 341 for i := 0 to aPatternSize - 1 - 1 do begin 342 DeltaJumpTable1[Ord(aPattern[i])]:=aPatternSize -1 - i; 343 end; 344 end; 345 346 function IsPrefix(const aPattern: PChar; const aPatternSize, aPos: SizeInt): Boolean; 347 var 348 i: SizeInt; 349 SuffixLength: SizeInt; 350 begin 351 SuffixLength:=aPatternSize-aPos; 352 for i := 0 to SuffixLength-1 do begin 353 if (aPattern[i] <> aPattern[aPos+i]) then begin 354 exit(false); 355 end; 356 end; 357 Result:=true; 358 end; 359 360 function SuffixLength(const aPattern: PChar; const aPatternSize, aPos: SizeInt): SizeInt; 361 var 362 i: SizeInt; 363 begin 364 i:=0; 365 while (i<aPos) and (aPattern[aPos-i] = aPattern[aPatternSize-1-i]) do begin 366 inc(i); 367 end; 368 Result:=i; 369 end; 370 371 procedure MakeDeltaJumpTable2(var DeltaJumpTable2: SizeIntArray; const aPattern: PChar; const aPatternSize: SizeInt); 372 var 373 Position: SizeInt; 374 LastPrefixIndex: SizeInt; 375 SuffixLengthValue: SizeInt; 376 begin 377 LastPrefixIndex:=aPatternSize-1; 378 Position:=aPatternSize-1; 379 while Position>=0 do begin 380 if IsPrefix(aPattern,aPatternSize,Position+1) then begin 381 LastPrefixIndex := Position+1; 382 end; 383 DeltaJumpTable2[Position] := LastPrefixIndex + (aPatternSize-1 - Position); 384 Dec(Position); 385 end; 386 Position:=0; 387 while Position<aPatternSize-1 do begin 388 SuffixLengthValue:=SuffixLength(aPattern,aPatternSize,Position); 389 if aPattern[Position-SuffixLengthValue] <> aPattern[aPatternSize-1 - SuffixLengthValue] then begin 390 DeltaJumpTable2[aPatternSize - 1 - SuffixLengthValue] := aPatternSize - 1 - Position + SuffixLengthValue; 391 end; 392 Inc(Position); 393 end; 394 end; 395 396 //Resizes the allocated space for replacement index 397 procedure ResizeAllocatedMatches; 398 begin 399 MatchesAllocatedLimit:=MatchesCount+MATCHESCOUNTRESIZER; 400 SetLength(aMatches,MatchesAllocatedLimit); 401 end; 402 403 //Add a match to be replaced 404 procedure AddMatch(const aPosition: SizeInt); inline; 405 begin 406 if MatchesCount = MatchesAllocatedLimit then begin 407 ResizeAllocatedMatches; 408 end; 409 aMatches[MatchesCount]:=aPosition; 410 inc(MatchesCount); 411 end; 412var 413 i,j: SizeInt; 414 DeltaJumpTable1: array [0..ALPHABET_LENGHT-1] of SizeInt; 415 DeltaJumpTable2: SizeIntArray; 416begin 417 MatchesCount:=0; 418 MatchesAllocatedLimit:=0; 419 SetLength(aMatches,MatchesCount); 420 if OldPatternSize=0 then begin 421 Exit; 422 end; 423 SetLength(DeltaJumpTable2,OldPatternSize); 424 425 MakeDeltaJumpTable1(DeltaJumpTable1,OldPattern,OldPatternSize); 426 MakeDeltaJumpTable2(DeltaJumpTable2,OldPattern,OldPatternSize); 427 428 i:=OldPatternSize-1; 429 while i < SSize do begin 430 j:=OldPatternSize-1; 431 while (j>=0) and (S[i] = OldPattern[j]) do begin 432 dec(i); 433 dec(j); 434 end; 435 if (j<0) then begin 436 AddMatch(i+1); 437 //Only first match ? 438 if not aMatchAll then break; 439 inc(i,DeltaJumpTable2[0]); 440 end else begin 441 i:=i + Max(DeltaJumpTable1[ord(s[i])],DeltaJumpTable2[j]); 442 end; 443 end; 444 SetLength(aMatches,MatchesCount); 445 Result:=MatchesCount>0; 446end; 447 448function FindMatchesBoyerMooreCaseInSensitive(const S, OldPattern: PChar; const SSize, OldPatternSize: SizeInt; out 449 aMatches: SizeIntArray; const aMatchAll: Boolean): Boolean; 450const 451 ALPHABET_LENGHT=256; 452 MATCHESCOUNTRESIZER=100; //Arbitrary value. Memory used = MATCHESCOUNTRESIZER * sizeof(SizeInt) 453var 454 //Lowercased OldPattern 455 lPattern: string; 456 //Array of lowercased alphabet 457 lCaseArray: array [0..ALPHABET_LENGHT-1] of char; 458 //Stores the amount of replaces that will take place 459 MatchesCount: SizeInt; 460 //Currently allocated space for matches. 461 MatchesAllocatedLimit: SizeInt; 462type 463 AlphabetArray=array [0..ALPHABET_LENGHT-1] of SizeInt; 464 465 function Max(const a1,a2: SizeInt): SizeInt; 466 begin 467 if a1>a2 then Result:=a1 else Result:=a2; 468 end; 469 470 procedure MakeDeltaJumpTable1(out DeltaJumpTable1: AlphabetArray; const aPattern: PChar; const aPatternSize: SizeInt); 471 var 472 i: SizeInt; 473 begin 474 for i := 0 to ALPHABET_LENGHT-1 do begin 475 DeltaJumpTable1[i]:=aPatternSize; 476 end; 477 //Last char do not enter in the equation 478 for i := 0 to aPatternSize - 1 - 1 do begin 479 DeltaJumpTable1[Ord(aPattern[i])]:=aPatternSize - 1 - i; 480 end; 481 end; 482 483 function IsPrefix(const aPattern: PChar; const aPatternSize, aPos: SizeInt): Boolean; inline; 484 var 485 i: SizeInt; 486 SuffixLength: SizeInt; 487 begin 488 SuffixLength:=aPatternSize-aPos; 489 for i := 0 to SuffixLength-1 do begin 490 if (aPattern[i+1] <> aPattern[aPos+i]) then begin 491 exit(false); 492 end; 493 end; 494 Result:=true; 495 end; 496 497 function SuffixLength(const aPattern: PChar; const aPatternSize, aPos: SizeInt): SizeInt; inline; 498 var 499 i: SizeInt; 500 begin 501 i:=0; 502 while (i<aPos) and (aPattern[aPos-i] = aPattern[aPatternSize-1-i]) do begin 503 inc(i); 504 end; 505 Result:=i; 506 end; 507 508 procedure MakeDeltaJumpTable2(var DeltaJumpTable2: SizeIntArray; const aPattern: PChar; const aPatternSize: SizeInt); 509 var 510 Position: SizeInt; 511 LastPrefixIndex: SizeInt; 512 SuffixLengthValue: SizeInt; 513 begin 514 LastPrefixIndex:=aPatternSize-1; 515 Position:=aPatternSize-1; 516 while Position>=0 do begin 517 if IsPrefix(aPattern,aPatternSize,Position+1) then begin 518 LastPrefixIndex := Position+1; 519 end; 520 DeltaJumpTable2[Position] := LastPrefixIndex + (aPatternSize-1 - Position); 521 Dec(Position); 522 end; 523 Position:=0; 524 while Position<aPatternSize-1 do begin 525 SuffixLengthValue:=SuffixLength(aPattern,aPatternSize,Position); 526 if aPattern[Position-SuffixLengthValue] <> aPattern[aPatternSize-1 - SuffixLengthValue] then begin 527 DeltaJumpTable2[aPatternSize - 1 - SuffixLengthValue] := aPatternSize - 1 - Position + SuffixLengthValue; 528 end; 529 Inc(Position); 530 end; 531 end; 532 533 //Resizes the allocated space for replacement index 534 procedure ResizeAllocatedMatches; 535 begin 536 MatchesAllocatedLimit:=MatchesCount+MATCHESCOUNTRESIZER; 537 SetLength(aMatches,MatchesAllocatedLimit); 538 end; 539 540 //Add a match to be replaced 541 procedure AddMatch(const aPosition: SizeInt); inline; 542 begin 543 if MatchesCount = MatchesAllocatedLimit then begin 544 ResizeAllocatedMatches; 545 end; 546 aMatches[MatchesCount]:=aPosition; 547 inc(MatchesCount); 548 end; 549var 550 i,j: SizeInt; 551 DeltaJumpTable1: array [0..ALPHABET_LENGHT-1] of SizeInt; 552 DeltaJumpTable2: SizeIntArray; 553 //Pointer to lowered OldPattern 554 plPattern: PChar; 555begin 556 MatchesCount:=0; 557 MatchesAllocatedLimit:=0; 558 SetLength(aMatches,MatchesCount); 559 if OldPatternSize=0 then begin 560 Exit; 561 end; 562 563 //Build an internal array of lowercase version of every possible char. 564 for j := 0 to Pred(ALPHABET_LENGHT) do begin 565 lCaseArray[j]:=AnsiLowerCase(char(j))[1]; 566 end; 567 568 //Create the new lowercased pattern 569 SetLength(lPattern,OldPatternSize); 570 for j := 0 to Pred(OldPatternSize) do begin 571 lPattern[j+1]:=lCaseArray[ord(OldPattern[j])]; 572 end; 573 574 SetLength(DeltaJumpTable2,OldPatternSize); 575 576 MakeDeltaJumpTable1(DeltaJumpTable1,@lPattern[1],OldPatternSize); 577 MakeDeltaJumpTable2(DeltaJumpTable2,@lPattern[1],OldPatternSize); 578 579 plPattern:=@lPattern[1]; 580 i:=OldPatternSize-1; 581 while i < SSize do begin 582 j:=OldPatternSize-1; 583 while (j>=0) and (lCaseArray[Ord(S[i])] = plPattern[j]) do begin 584 dec(i); 585 dec(j); 586 end; 587 if (j<0) then begin 588 AddMatch(i+1); 589 //Only first match ? 590 if not aMatchAll then break; 591 inc(i,DeltaJumpTable2[0]); 592 end else begin 593 i:=i + Max(DeltaJumpTable1[Ord(lCaseArray[Ord(s[i])])],DeltaJumpTable2[j]); 594 end; 595 end; 596 SetLength(aMatches,MatchesCount); 597 Result:=MatchesCount>0; 598end; 599 600function StringReplaceFast(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags; out aCount : Integer): string; 601const 602 MATCHESCOUNTRESIZER=100; //Arbitrary value. Memory used = MATCHESCOUNTRESIZER * sizeof(SizeInt) 603var 604 //Stores where a replace will take place 605 Matches: array of SizeInt; 606 //Stores the amount of replaces that will take place 607 MatchesCount: SizeInt; 608 //Currently allocated space for matches. 609 MatchesAllocatedLimit: SizeInt; 610 //Uppercase version of pattern 611 PatternUppercase: string; 612 //Lowercase version of pattern 613 PatternLowerCase: string; 614 //Index 615 MatchIndex: SizeInt; 616 MatchLimit: SizeInt; 617 MatchInternal: SizeInt; 618 MatchTarget: SizeInt; 619 AdvanceIndex: SizeInt; 620 621 //Miscelanous variables 622 OldPatternSize: SizeInt; 623 NewPatternSize: SizeInt; 624 625 //Resizes the allocated space for replacement index 626 procedure ResizeAllocatedMatches; 627 begin 628 MatchesAllocatedLimit:=MatchesCount+MATCHESCOUNTRESIZER; 629 SetLength(Matches,MatchesAllocatedLimit); 630 end; 631 632 //Add a match to be replaced 633 procedure AddMatch(const aPosition: SizeInt); inline; 634 begin 635 if MatchesCount = MatchesAllocatedLimit then begin 636 ResizeAllocatedMatches; 637 end; 638 Matches[MatchesCount]:=aPosition; 639 inc(MatchesCount); 640 end; 641begin 642 aCount:=0; 643 if (OldPattern='') or (Length(OldPattern)>Length(S)) then begin 644 //This cases will never match nothing. 645 Result:=S; 646 exit; 647 end; 648 Result:=''; 649 OldPatternSize:=Length(OldPattern); 650 MatchesCount:=0; 651 MatchesAllocatedLimit:=0; 652 if rfIgnoreCase in Flags then begin 653 //Different algorithm for case sensitive and insensitive 654 //This is insensitive, so 2 new ansistrings are created for search pattern, one upper and one lower case. 655 //It is easy, usually, to create 2 versions of the match pattern than uppercased and lowered case each 656 //character in the "to be matched" string. 657 PatternUppercase:=AnsiUpperCase(OldPattern); 658 PatternLowerCase:=AnsiLowerCase(OldPattern); 659 MatchIndex:=Length(OldPattern); 660 MatchLimit:=Length(S); 661 NewPatternSize:=Length(NewPattern); 662 while MatchIndex <= MatchLimit do begin 663 if (S[MatchIndex]=PatternLowerCase[OldPatternSize]) or (S[MatchIndex]=PatternUppercase[OldPatternSize]) then begin 664 //Match backwards... 665 MatchInternal:=OldPatternSize-1; 666 MatchTarget:=MatchIndex-1; 667 while MatchInternal>=1 do begin 668 if (S[MatchTarget]=PatternLowerCase[MatchInternal]) or (S[MatchTarget]=PatternUppercase[MatchInternal]) then begin 669 dec(MatchInternal); 670 dec(MatchTarget); 671 end else begin 672 break; 673 end; 674 end; 675 if MatchInternal=0 then begin 676 //Match found, all char meet the sequence 677 //MatchTarget points to char before, so matching is +1 678 AddMatch(MatchTarget+1); 679 inc(MatchIndex,OldPatternSize); 680 if not (rfReplaceAll in Flags) then begin 681 break; 682 end; 683 end else begin 684 //Match not found 685 inc(MatchIndex); 686 end; 687 end else begin 688 inc(MatchIndex); 689 end; 690 end; 691 end else begin 692 //Different algorithm for case sensitive and insensitive 693 //This is sensitive, so just 1 binary comprare 694 MatchIndex:=Length(OldPattern); 695 MatchLimit:=Length(S); 696 NewPatternSize:=Length(NewPattern); 697 while MatchIndex <= MatchLimit do begin 698 if (S[MatchIndex]=OldPattern[OldPatternSize]) then begin 699 //Match backwards... 700 MatchInternal:=OldPatternSize-1; 701 MatchTarget:=MatchIndex-1; 702 while MatchInternal>=1 do begin 703 if (S[MatchTarget]=OldPattern[MatchInternal]) then begin 704 dec(MatchInternal); 705 dec(MatchTarget); 706 end else begin 707 break; 708 end; 709 end; 710 if MatchInternal=0 then begin 711 //Match found, all char meet the sequence 712 //MatchTarget points to char before, so matching is +1 713 AddMatch(MatchTarget+1); 714 inc(MatchIndex,OldPatternSize); 715 if not (rfReplaceAll in Flags) then begin 716 break; 717 end; 718 end else begin 719 //Match not found 720 inc(MatchIndex); 721 end; 722 end else begin 723 inc(MatchIndex); 724 end; 725 end; 726 end; 727 //Create room enough for the result string 728 aCount:=MatchesCount; 729 SetLength(Result,Length(S)-OldPatternSize*MatchesCount+NewPatternSize*MatchesCount); 730 MatchIndex:=1; 731 MatchTarget:=1; 732 //Matches[x] are 1 based offsets 733 for MatchInternal := 0 to Pred(MatchesCount) do begin 734 //Copy information up to next match 735 AdvanceIndex:=Matches[MatchInternal]-MatchIndex; 736 if AdvanceIndex>0 then begin 737 move(S[MatchIndex],Result[MatchTarget],AdvanceIndex); 738 inc(MatchTarget,AdvanceIndex); 739 inc(MatchIndex,AdvanceIndex); 740 end; 741 //Copy the new replace information string 742 if NewPatternSize>0 then begin 743 move(NewPattern[1],Result[MatchTarget],NewPatternSize); 744 inc(MatchTarget,NewPatternSize); 745 end; 746 inc(MatchIndex,OldPatternSize); 747 end; 748 if MatchTarget<=Length(Result) then begin 749 //Add remain data at the end of source. 750 move(S[MatchIndex],Result[MatchTarget],Length(Result)-MatchTarget+1); 751 end; 752end; 753 754(* 755 StringReplaceBoyerMoore 756 757 Replaces one or many ocurrences of an ansistring in another ansistring by a new one. 758 It can perform the compare ignoring case (ansi). 759 760 * Parameters (Read only): 761 S: The string to be searched in. 762 OldPattern: The string to be searched. 763 NewPattern: The string to replace OldPattern matches. 764 Flags: 765 rfReplaceAll: Replace all occurrences. 766 rfIgnoreCase: Ignore case in OldPattern matching. 767 768 * Returns: 769 The modified string (if needed). 770 771 It is memory conservative, just sizeof(SizeInt) per match in blocks off 100 matches 772 plus Length(OldPattern)*2 in the case of ignoring case. 773 Memory copies are the minimun necessary. 774 Algorithm based in the Boyer-Moore string search algorithm. 775 776 It is faster when the "S" string is very long and the OldPattern is also 777 very big. As much big the OldPattern is, faster the search is too. 778 779 It uses 2 different helper versions of Boyer-Moore algorithm, one for case 780 sensitive and one for case INsensitive for speed reasons. 781 782*) 783 784function StringReplaceBoyerMoore(const S, OldPattern, NewPattern: string;Flags: TReplaceFlags; out aCount : Integer): string; 785var 786 Matches: SizeIntArray; 787 OldPatternSize: SizeInt; 788 NewPatternSize: SizeInt; 789 MatchesCount: SizeInt; 790 MatchIndex: SizeInt; 791 MatchTarget: SizeInt; 792 MatchInternal: SizeInt; 793 AdvanceIndex: SizeInt; 794begin 795 aCount:=0; 796 OldPatternSize:=Length(OldPattern); 797 NewPatternSize:=Length(NewPattern); 798 if (OldPattern='') or (Length(OldPattern)>Length(S)) then begin 799 Result:=S; 800 exit; 801 end; 802 803 if rfIgnoreCase in Flags then begin 804 FindMatchesBoyerMooreCaseINSensitive(@s[1],@OldPattern[1],Length(S),Length(OldPattern),Matches, rfReplaceAll in Flags); 805 end else begin 806 FindMatchesBoyerMooreCaseSensitive(@s[1],@OldPattern[1],Length(S),Length(OldPattern),Matches, rfReplaceAll in Flags); 807 end; 808 809 MatchesCount:=Length(Matches); 810 aCount:=MatchesCount; 811 812 //Create room enougth for the result string 813 SetLength(Result,Length(S)-OldPatternSize*MatchesCount+NewPatternSize*MatchesCount); 814 MatchIndex:=1; 815 MatchTarget:=1; 816 //Matches[x] are 0 based offsets 817 for MatchInternal := 0 to Pred(MatchesCount) do begin 818 //Copy information up to next match 819 AdvanceIndex:=Matches[MatchInternal]+1-MatchIndex; 820 if AdvanceIndex>0 then begin 821 move(S[MatchIndex],Result[MatchTarget],AdvanceIndex); 822 inc(MatchTarget,AdvanceIndex); 823 inc(MatchIndex,AdvanceIndex); 824 end; 825 //Copy the new replace information string 826 if NewPatternSize>0 then begin 827 move(NewPattern[1],Result[MatchTarget],NewPatternSize); 828 inc(MatchTarget,NewPatternSize); 829 end; 830 inc(MatchIndex,OldPatternSize); 831 end; 832 if MatchTarget<=Length(Result) then begin 833 //Add remain data at the end of source. 834 move(S[MatchIndex],Result[MatchTarget],Length(Result)-MatchTarget+1); 835 end; 836end; 837 838function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags; Algorithm: TStringReplaceAlgorithm): string; 839 840Var 841 C : Integer; 842 843begin 844 Result:=StringReplace(S, OldPattern, NewPattern, Flags,C,Algorithm); 845end; 846 847Function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags; out aCount : Integer; Algorithm : TStringReplaceAlgorithm = sraDefault): string; overload; 848 849 850begin 851 Case Algorithm of 852 sraDefault : Result:=sysutils.StringReplace(S,OldPattern,NewPattern,Flags,aCount); 853 sraManySmall : Result:=StringReplaceFast(S,OldPattern,NewPattern,Flags,aCount); 854 sraBoyerMoore : Result:=StringReplaceBoyerMoore(S,OldPattern,NewPattern,Flags,aCount); 855 end; 856end; 857 858 859function StringReplace(const S, OldPattern, NewPattern: unicodestring; Flags: TReplaceFlags): unicodestring; 860 861begin 862 Result:=sysutils.StringReplace(S,OldPattern,NewPattern,Flags); 863end; 864 865function StringReplace(const S, OldPattern, NewPattern: widestring; Flags: TReplaceFlags): widestring; 866 867begin 868 Result:=sysutils.StringReplace(S,OldPattern,NewPattern,Flags); 869end; 870 871 872function FindMatchesBoyerMooreCaseSensitive(const S, OldPattern: String; out aMatches: SizeIntArray; const aMatchAll: Boolean 873 ): Boolean; 874 875Var 876 I : SizeInt; 877 878begin 879 Result:=FindMatchesBoyerMooreCaseSensitive(PChar(S),Pchar(OldPattern),Length(S),Length(OldPattern),aMatches,aMatchAll); 880 For I:=0 to pred(Length(AMatches)) do 881 Inc(AMatches[i]); 882end; 883 884function FindMatchesBoyerMooreCaseInSensitive(const S, OldPattern: String; out aMatches: SizeIntArray; const aMatchAll: Boolean 885 ): Boolean; 886 887Var 888 I : SizeInt; 889 890begin 891 Result:=FindMatchesBoyerMooreCaseInSensitive(PChar(S),Pchar(OldPattern),Length(S),Length(OldPattern),aMatches,aMatchAll); 892 For I:=0 to pred(Length(AMatches)) do 893 Inc(AMatches[i]); 894end; 895 896 897{ --------------------------------------------------------------------- 898 Possibly Exception raising functions 899 ---------------------------------------------------------------------} 900 901 902function Hex2Dec(const S: string): Longint; 903var 904 HexStr: string; 905begin 906 if Pos('$',S)=0 then 907 HexStr:='$'+ S 908 else 909 HexStr:=S; 910 Result:=StrToInt(HexStr); 911end; 912 913function Hex2Dec64(const S: string): int64; 914var 915 HexStr: string; 916begin 917 if Pos('$',S)=0 then 918 HexStr:='$'+ S 919 else 920 HexStr:=S; 921 Result:=StrToInt64(HexStr); 922end; 923 924 925{ 926 We turn off implicit exceptions, since these routines are tested, and it 927 saves 20% codesize (and some speed) and don't throw exceptions, except maybe 928 heap related. If they don't, that is consider a bug. 929 930 In the future, be wary with routines that use strtoint, floating point 931 and/or format() derivatives. And check every divisor for 0. 932} 933 934{$IMPLICITEXCEPTIONS OFF} 935 936{ --------------------------------------------------------------------- 937 Case insensitive search/replace 938 ---------------------------------------------------------------------} 939function AnsiResemblesText(const AText, AOther: string): Boolean; 940 941begin 942 if Assigned(AnsiResemblesProc) then 943 Result:=AnsiResemblesProc(AText,AOther) 944 else 945 Result:=False; 946end; 947 948function AnsiContainsText(const AText, ASubText: string): Boolean; 949begin 950 AnsiContainsText:=AnsiPos(AnsiUppercase(ASubText),AnsiUppercase(AText))>0; 951end; 952 953 954function AnsiStartsText(const ASubText, AText: string): Boolean; 955begin 956 Result := (ASubText = '') or AnsiSameText(LeftStr(AText, Length(ASubText)), ASubText); 957end; 958 959 960function AnsiEndsText(const ASubText, AText: string): Boolean; 961begin 962 Result := (ASubText = '') or AnsiSameText(RightStr(AText, Length(ASubText)), ASubText); 963end; 964 965 966function StartsText(const ASubText, AText: string): Boolean; inline; 967begin 968 Result := AnsiStartsText(ASubText, AText); 969end; 970 971 972function EndsText(const ASubText, AText: string): Boolean; 973begin 974 Result := AnsiEndsText(ASubText, AText); 975end; 976 977function ResemblesText(const AText, AOther: string): Boolean; 978begin 979 if Assigned(ResemblesProc) then 980 Result := ResemblesProc(AText, AOther) 981 else 982 Result := False; 983end; 984 985function ContainsText(const AText, ASubText: string): Boolean; 986begin 987 Result := AnsiContainsText(AText, ASubText); 988end; 989 990function MatchText(const AText: string; const AValues: array of string): Boolean; 991begin 992 Result := AnsiMatchText(AText, AValues); 993end; 994 995function IndexText(const AText: string; const AValues: array of string): Integer; 996begin 997 Result := AnsiIndexText(AText, AValues); 998end; 999 1000function ContainsStr(const AText, ASubText: string): Boolean; 1001begin 1002 Result := AnsiContainsStr(AText, ASubText); 1003end; 1004 1005function MatchStr(const AText: string; const AValues: array of string): Boolean; 1006begin 1007 Result := AnsiMatchStr(AText, AValues); 1008end; 1009 1010function IndexStr(const AText: string; const AValues: array of string): Integer; 1011begin 1012 Result := AnsiIndexStr(AText, AValues); 1013end; 1014 1015function AnsiReplaceText(const AText, AFromText, AToText: string): string; 1016begin 1017 Result := StringReplace(AText,AFromText,AToText,[rfReplaceAll,rfIgnoreCase]); 1018end; 1019 1020function AnsiMatchText(const AText: string; const AValues: array of string): Boolean; 1021begin 1022 Result:=(AnsiIndexText(AText,AValues)<>-1) 1023end; 1024 1025function AnsiIndexText(const AText: string; const AValues: array of string): Integer; 1026begin 1027 for Result := Low(AValues) to High(AValues) do 1028 if AnsiSameText(AValues[Result], AText) then 1029 Exit; 1030 Result := -1; 1031end; 1032 1033 1034{ --------------------------------------------------------------------- 1035 Case sensitive search/replace 1036 ---------------------------------------------------------------------} 1037 1038function AnsiContainsStr(const AText, ASubText: string): Boolean; 1039begin 1040 Result := AnsiPos(ASubText,AText)>0; 1041end; 1042 1043 1044function AnsiStartsStr(const ASubText, AText: string): Boolean; 1045begin 1046 Result := (ASubText = '') or (LeftStr(AText, Length(ASubText)) = ASubText); 1047end; 1048 1049 1050function AnsiEndsStr(const ASubText, AText: string): Boolean; 1051begin 1052 Result := (ASubText = '') or (RightStr(AText, Length(ASubText)) = ASubText); 1053end; 1054 1055 1056function StartsStr(const ASubText, AText: string): Boolean; 1057begin 1058 if (Length(AText) >= Length(ASubText)) and (ASubText <> '') then 1059 Result := StrLComp(PChar(ASubText), PChar(AText), Length(ASubText)) = 0 1060 else 1061 Result := (AsubText=''); 1062end; 1063 1064 1065function EndsStr(const ASubText, AText: string): Boolean; 1066begin 1067 if Length(AText) >= Length(ASubText) then 1068 Result := StrLComp(PChar(ASubText), 1069 PChar(AText) + Length(AText) - Length(ASubText), Length(ASubText)) = 0 1070 else 1071 Result := False; 1072end; 1073 1074 1075function AnsiReplaceStr(const AText, AFromText, AToText: string): string; 1076begin 1077Result := StringReplace(AText,AFromText,AToText,[rfReplaceAll]); 1078end; 1079 1080 1081function AnsiMatchStr(const AText: string; const AValues: array of string): Boolean; 1082begin 1083 Result:=AnsiIndexStr(AText,Avalues)<>-1; 1084end; 1085 1086 1087function AnsiIndexStr(const AText: string; const AValues: array of string): Integer; 1088var 1089 i : longint; 1090begin 1091 result:=-1; 1092 if (high(AValues)=-1) or (High(AValues)>MaxInt) Then 1093 Exit; 1094 for i:=low(AValues) to High(Avalues) do 1095 if (avalues[i]=AText) Then 1096 exit(i); // make sure it is the first val. 1097end; 1098 1099 1100function MatchStr(const AText: UnicodeString; const AValues: array of UnicodeString): Boolean; 1101begin 1102 Result := IndexStr(AText,AValues) <> -1; 1103end; 1104 1105function MatchText(const AText: UnicodeString; const AValues: array of UnicodeString): Boolean; 1106begin 1107 Result := IndexText(AText,AValues) <> -1; 1108end; 1109 1110function IndexStr(const AText: UnicodeString; const AValues: array of UnicodeString): Integer; 1111var 1112 i: longint; 1113begin 1114 Result := -1; 1115 if (high(AValues) = -1) or (High(AValues) > MaxInt) Then 1116 Exit; 1117 for i := low(AValues) to High(Avalues) do 1118 if (avalues[i] = AText) Then 1119 exit(i); // make sure it is the first val. 1120end; 1121 1122function IndexText(const AText: UnicodeString; const AValues: array of UnicodeString): Integer; 1123 1124var 1125 i : Integer; 1126 1127begin 1128 Result:=-1; 1129 if (high(AValues)=-1) or (High(AValues)>MaxInt) Then 1130 Exit; 1131 for i:=low(AValues) to High(Avalues) do 1132 if UnicodeCompareText(avalues[i],atext)=0 Then 1133 exit(i); // make sure it is the first val. 1134end; 1135 1136operator in(const AText: string; const AValues: array of string): Boolean; 1137begin 1138 Result := AnsiIndexStr(AText,AValues) <>-1; 1139end; 1140 1141 1142operator in(const AText: UnicodeString; const AValues: array of UnicodeString): Boolean; 1143begin 1144 Result := IndexStr(AText,AValues) <> -1; 1145end; 1146{ --------------------------------------------------------------------- 1147 Playthingies 1148 ---------------------------------------------------------------------} 1149 1150function DupeString(const AText: string; ACount: Integer): string; 1151 1152var 1153 Len: SizeInt; 1154 Source, Target: PByte; 1155 1156begin 1157 Len := Length(AText); 1158 SetLength(Result, ACount * Len); 1159 // Use PByte to skip implicit UniqueString, because SetLength always unique 1160 Target := PByte(Result); 1161 if Target = nil then // ACount = 0 or AText = '' 1162 Exit; 1163 // Now ACount > 0 and Len > 0 1164 Source := PByte(AText); 1165 repeat 1166 Move(Source[0], Target[0], Len * SizeOf(Char)); 1167 Inc(Target, Len * SizeOf(Char)); 1168 Dec(ACount); 1169 until ACount = 0; 1170end; 1171 1172function ReverseString(const AText: string): string; 1173 1174var 1175 i,j : SizeInt; 1176 1177begin 1178 setlength(result,length(atext)); 1179 i:=1; j:=length(atext); 1180 while (i<=j) do 1181 begin 1182 result[i]:=atext[j-i+1]; 1183 inc(i); 1184 end; 1185end; 1186 1187 1188function AnsiReverseString(const AText: AnsiString): AnsiString; 1189 1190begin 1191 Result:=ReverseString(AText); 1192end; 1193 1194 1195 1196function StuffString(const AText: string; AStart, ALength: Cardinal; const ASubText: string): string; 1197 1198var i,j,k : SizeUInt; 1199 1200begin 1201 j:=length(ASubText); 1202 i:=length(AText); 1203 if AStart>i then 1204 aStart:=i+1; 1205 k:=i+1-AStart; 1206 if ALength> k then 1207 ALength:=k; 1208 SetLength(Result,i+j-ALength); 1209 move (AText[1],result[1],AStart-1); 1210 move (ASubText[1],result[AStart],j); 1211 move (AText[AStart+ALength], Result[AStart+j],i+1-AStart-ALength); 1212end; 1213 1214function RandomFrom(const AValues: array of string): string; 1215 1216begin 1217 if high(AValues)=-1 then exit(''); 1218 result:=Avalues[random(High(AValues)+1)]; 1219end; 1220 1221function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string): string; 1222 1223begin 1224 if avalue then 1225 result:=atrue 1226 else 1227 result:=afalse; 1228end; 1229 1230function NaturalCompareText(const Str1, Str2: string; const ADecSeparator, AThousandSeparator: Char): Integer; 1231{ 1232 NaturalCompareBase compares strings in a collated order and 1233 so numbers are sorted too. It sorts like this: 1234 1235 01 1236 001 1237 0001 1238 1239 and 1240 1241 0 1242 00 1243 000 1244 000_A 1245 000_B 1246 1247 in a intuitive order. 1248 } 1249var 1250 Num1, Num2: double; 1251 pStr1, pStr2: PChar; 1252 Len1, Len2: SizeInt; 1253 TextLen1, TextLen2: SizeInt; 1254 TextStr1: string = ''; 1255 TextStr2: string = ''; 1256 i: SizeInt; 1257 j: SizeInt; 1258 1259 function Sign(const AValue: sizeint): integer;inline; 1260 1261 begin 1262 If Avalue<0 then 1263 Result:=-1 1264 else If Avalue>0 then 1265 Result:=1 1266 else 1267 Result:=0; 1268 end; 1269 1270 function IsNumber(ch: char): boolean; 1271 begin 1272 Result := ch in ['0'..'9']; 1273 end; 1274 1275 function GetInteger(var pch: PChar; var Len: sizeint): double; 1276 begin 1277 Result := 0; 1278 while (pch^ <> #0) and IsNumber(pch^) do 1279 begin 1280 Result := Result * 10 + Ord(pch^) - Ord('0'); 1281 Inc(Len); 1282 Inc(pch); 1283 end; 1284 end; 1285 1286 procedure GetChars; 1287 begin 1288 TextLen1 := 0; 1289 while not ((pStr1 + TextLen1)^ in ['0'..'9']) and ((pStr1 + TextLen1)^ <> #0) do 1290 Inc(TextLen1); 1291 SetLength(TextStr1, TextLen1); 1292 i := 1; 1293 j := 0; 1294 while i <= TextLen1 do 1295 begin 1296 TextStr1[i] := (pStr1 + j)^; 1297 Inc(i); 1298 Inc(j); 1299 end; 1300 1301 TextLen2 := 0; 1302 while not ((pStr2 + TextLen2)^ in ['0'..'9']) and ((pStr2 + TextLen2)^ <> #0) do 1303 Inc(TextLen2); 1304 SetLength(TextStr2, TextLen2); 1305 i := 1; 1306 j := 0; 1307 while i <= TextLen2 do 1308 begin 1309 TextStr2[i] := (pStr2 + j)^; 1310 Inc(i); 1311 Inc(j); 1312 end; 1313 end; 1314 1315begin 1316 if (Str1 <> '') and (Str2 <> '') then 1317 begin 1318 pStr1 := PChar(Str1); 1319 pStr2 := PChar(Str2); 1320 Result := 0; 1321 while not ((pStr1^ = #0) or (pStr2^ = #0)) do 1322 begin 1323 TextLen1 := 1; 1324 TextLen2 := 1; 1325 Len1 := 0; 1326 Len2 := 0; 1327 while (pStr1^ = ' ') do 1328 begin 1329 Inc(pStr1); 1330 Inc(Len1); 1331 end; 1332 while (pStr2^ = ' ') do 1333 begin 1334 Inc(pStr2); 1335 Inc(Len2); 1336 end; 1337 if IsNumber(pStr1^) and IsNumber(pStr2^) then 1338 begin 1339 Num1 := GetInteger(pStr1, Len1); 1340 Num2 := GetInteger(pStr2, Len2); 1341 if Num1 < Num2 then 1342 Result := -1 1343 else if Num1 > Num2 then 1344 Result := 1 1345 else 1346 begin 1347 Result := Sign(Len1 - Len2); 1348 end; 1349 Dec(pStr1); 1350 Dec(pStr2); 1351 end 1352 else 1353 begin 1354 GetChars; 1355 if TextStr1 <> TextStr2 then 1356 Result := WideCompareText(UTF8Decode(TextStr1), UTF8Decode(TextStr2)) 1357 else 1358 Result := 0; 1359 end; 1360 if Result <> 0 then 1361 Break; 1362 Inc(pStr1, TextLen1); 1363 Inc(pStr2, TextLen2); 1364 end; 1365 end; 1366 Num1 := Length(Str1); 1367 Num2 := Length(Str2); 1368 if (Result = 0) and (Num1 <> Num2) then 1369 begin 1370 if Num1 < Num2 then 1371 Result := -1 1372 else 1373 Result := 1; 1374 end; 1375end; 1376 1377function SplitString(const S, Delimiters: string): TStringDynArray; 1378begin 1379 Result := S.Split(Delimiters); 1380end; 1381 1382function NaturalCompareText (const S1 , S2 : string ): Integer ; 1383begin 1384 Result := NaturalCompareText(S1, S2, 1385 DefaultFormatSettings.DecimalSeparator, 1386 DefaultFormatSettings.ThousandSeparator); 1387end; 1388 1389{ --------------------------------------------------------------------- 1390 VB emulations. 1391 ---------------------------------------------------------------------} 1392 1393function LeftStr(const AText: AnsiString; const ACount: SizeInt): AnsiString; 1394 1395begin 1396 Result:=Copy(AText,1,ACount); 1397end; 1398 1399function RightStr(const AText: AnsiString; const ACount: SizeInt): AnsiString; 1400 1401var j,l:SizeInt; 1402 1403begin 1404 l:=length(atext); 1405 j:=ACount; 1406 if j>l then j:=l; 1407 Result:=Copy(AText,l-j+1,j); 1408end; 1409 1410function MidStr(const AText: AnsiString; const AStart, ACount: SizeInt): AnsiString; 1411 1412begin 1413 if (ACount=0) or (AStart>length(atext)) then 1414 exit(''); 1415 Result:=Copy(AText,AStart,ACount); 1416end; 1417 1418 1419 1420function LeftBStr(const AText: AnsiString; const AByteCount: SizeInt): AnsiString; 1421 1422begin 1423 Result:=LeftStr(AText,AByteCount); 1424end; 1425 1426 1427function RightBStr(const AText: AnsiString; const AByteCount: SizeInt): AnsiString; 1428begin 1429 Result:=RightStr(Atext,AByteCount); 1430end; 1431 1432 1433function MidBStr(const AText: AnsiString; const AByteStart, AByteCount: SizeInt): AnsiString; 1434begin 1435 Result:=MidStr(AText,AByteStart,AByteCount); 1436end; 1437 1438 1439function AnsiLeftStr(const AText: AnsiString; const ACount: SizeInt): AnsiString; 1440begin 1441 Result := copy(AText,1,ACount); 1442end; 1443 1444 1445function AnsiRightStr(const AText: AnsiString; const ACount: SizeInt): AnsiString; 1446begin 1447 Result := copy(AText,length(AText)-ACount+1,ACount); 1448end; 1449 1450 1451function AnsiMidStr(const AText: AnsiString; const AStart, ACount: SizeInt): AnsiString; 1452begin 1453 Result:=Copy(AText,AStart,ACount); 1454end; 1455 1456 1457function LeftStr(const AText: WideString; const ACount: SizeInt): WideString; 1458begin 1459 Result:=Copy(AText,1,ACount); 1460end; 1461 1462 1463function RightStr(const AText: WideString; const ACount: SizeInt): WideString; 1464var 1465 j,l:SizeInt; 1466begin 1467 l:=length(atext); 1468 j:=ACount; 1469 if j>l then j:=l; 1470 Result:=Copy(AText,l-j+1,j); 1471end; 1472 1473 1474function MidStr(const AText: WideString; const AStart, ACount: SizeInt): WideString; 1475begin 1476 Result:=Copy(AText,AStart,ACount); 1477end; 1478 1479 1480{ --------------------------------------------------------------------- 1481 Extended search and replace 1482 ---------------------------------------------------------------------} 1483 1484type 1485 TEqualFunction = function (const a,b : char) : boolean; 1486 1487function EqualWithCase (const a,b : char) : boolean; 1488begin 1489 result := (a = b); 1490end; 1491 1492function EqualWithoutCase (const a,b : char) : boolean; 1493begin 1494 result := (lowerCase(a) = lowerCase(b)); 1495end; 1496 1497function IsWholeWord (bufstart, bufend, wordstart, wordend : pchar) : boolean; 1498begin 1499 // Check start 1500 result := ((wordstart = bufstart) or ((wordstart-1)^ in worddelimiters)) and 1501 // Check end 1502 ((wordend = bufend) or ((wordend+1)^ in worddelimiters)); 1503end; 1504 1505function SearchDown(buf,aStart,endchar:pchar; SearchString:string; 1506 Equals : TEqualFunction; WholeWords:boolean) : pchar; 1507var Found : boolean; 1508 s, c : pchar; 1509begin 1510 result := aStart; 1511 Found := false; 1512 while not Found and (result <= endchar) do 1513 begin 1514 // Search first letter 1515 while (result <= endchar) and not Equals(result^,SearchString[1]) do 1516 inc (result); 1517 // Check if following is searchstring 1518 c := result; 1519 s := @(Searchstring[1]); 1520 Found := true; 1521 while (c <= endchar) and (s^ <> #0) and Found do 1522 begin 1523 Found := Equals(c^, s^); 1524 inc (c); 1525 inc (s); 1526 end; 1527 if s^ <> #0 then 1528 Found := false; 1529 // Check if it is a word 1530 if Found and WholeWords then 1531 Found := IsWholeWord(buf,endchar,result,c-1); 1532 if not found then 1533 inc (result); 1534 end; 1535 if not Found then 1536 result := nil; 1537end; 1538 1539function SearchUp(buf,aStart,endchar:pchar; SearchString:string; 1540 equals : TEqualFunction; WholeWords:boolean) : pchar; 1541var Found : boolean; 1542 s, c, l : pchar; 1543begin 1544 result := aStart; 1545 Found := false; 1546 l := @(SearchString[length(SearchString)]); 1547 while not Found and (result >= buf) do 1548 begin 1549 // Search last letter 1550 while (result >= buf) and not Equals(result^,l^) do 1551 dec (result); 1552 // Check if before is searchstring 1553 c := result; 1554 s := l; 1555 Found := true; 1556 while (c >= buf) and (s >= @SearchString[1]) and Found do 1557 begin 1558 Found := Equals(c^, s^); 1559 dec (c); 1560 dec (s); 1561 end; 1562 if (s >= @(SearchString[1])) then 1563 Found := false; 1564 // Check if it is a word 1565 if Found and WholeWords then 1566 Found := IsWholeWord(buf,endchar,c+1,result); 1567 if found then 1568 result := c+1 1569 else 1570 dec (result); 1571 end; 1572 if not Found then 1573 result := nil; 1574end; 1575 1576//function SearchDown(buf,aStart,endchar:pchar; SearchString:string; equal : TEqualFunction; WholeWords:boolean) : pchar; 1577function SearchBuf(Buf: PChar; BufLen: SizeInt; SelStart, SelLength: SizeInt; SearchString: String; Options: TStringSearchOptions 1578 ): PChar; 1579var 1580 equal : TEqualFunction; 1581begin 1582 SelStart := SelStart + SelLength; 1583 if (SearchString = '') or (SelStart > BufLen) or (SelStart < 0) then 1584 result := nil 1585 else 1586 begin 1587 if soMatchCase in Options then 1588 Equal := @EqualWithCase 1589 else 1590 Equal := @EqualWithoutCase; 1591 if soDown in Options then 1592 result := SearchDown(buf,buf+SelStart,Buf+(BufLen-1), SearchString, Equal, (soWholeWord in Options)) 1593 else 1594 result := SearchUp(buf,buf+SelStart,Buf+(Buflen-1), SearchString, Equal, (soWholeWord in Options)); 1595 end; 1596end; 1597 1598 1599function SearchBuf(Buf: PChar; BufLen: SizeInt; SelStart, SelLength: SizeInt; SearchString: String): PChar; // ; Options: TStringSearchOptions = [soDown] 1600begin 1601 Result:=SearchBuf(Buf,BufLen,SelStart,SelLength,SearchString,[soDown]); 1602end; 1603 1604function PosEx(const SubStr, S: string; Offset: SizeUint): SizeInt; 1605 1606var 1607 i,MaxLen, SubLen : SizeInt; 1608 SubFirst: Char; 1609 pc : pchar; 1610begin 1611 PosEx:=0; 1612 SubLen := Length(SubStr); 1613 if (SubLen > 0) and (Offset > 0) and (Offset <= Cardinal(Length(S))) then 1614 begin 1615 MaxLen := Length(S)- SubLen; 1616 SubFirst := SubStr[1]; 1617 i := indexbyte(S[Offset],Length(S) - Offset + 1, Byte(SubFirst)); 1618 while (i >= 0) and ((i + sizeint(Offset) - 1) <= MaxLen) do 1619 begin 1620 pc := @S[i+SizeInt(Offset)]; 1621 //we know now that pc^ = SubFirst, because indexbyte returned a value > -1 1622 if (CompareByte(Substr[1],pc^,SubLen) = 0) then 1623 begin 1624 PosEx := i + SizeInt(Offset); 1625 Exit; 1626 end; 1627 //point Offset to next char in S 1628 Offset := sizeuint(i) + Offset + 1; 1629 i := indexbyte(S[Offset],Length(S) - Offset + 1, Byte(SubFirst)); 1630 end; 1631 end; 1632end; 1633 1634function PosEx(c: char; const S: string; Offset: SizeUint): SizeInt; 1635 1636var 1637 p,Len : SizeInt; 1638 1639begin 1640 Len := length(S); 1641 if (Offset < 1) or (Offset > SizeUInt(Length(S))) then exit(0); 1642 Len := length(S); 1643 p := indexbyte(S[Offset],Len-offset+1,Byte(c)); 1644 if (p < 0) then 1645 PosEx := 0 1646 else 1647 PosEx := p + sizeint(Offset); 1648end; 1649 1650function PosEx(const SubStr, S: string): SizeInt; // Offset: Cardinal = 1 1651begin 1652 posex:=posex(substr,s,1); 1653end; 1654 1655function PosEx(const SubStr, S: UnicodeString; Offset: SizeUint): SizeInt; 1656 1657var 1658 i,MaxLen, SubLen : SizeInt; 1659 SubFirst: WideChar; 1660 pc : pwidechar; 1661begin 1662 PosEx:=0; 1663 SubLen := Length(SubStr); 1664 if (SubLen > 0) and (Offset > 0) and (Offset <= Cardinal(Length(S))) then 1665 begin 1666 MaxLen := Length(S)- SubLen; 1667 SubFirst := SubStr[1]; 1668 i := indexword(S[Offset],Length(S) - Offset + 1, Word(SubFirst)); 1669 while (i >= 0) and ((i + sizeint(Offset) - 1) <= MaxLen) do 1670 begin 1671 pc := @S[i+SizeInt(Offset)]; 1672 //we know now that pc^ = SubFirst, because indexbyte returned a value > -1 1673 if (CompareWord(Substr[1],pc^,SubLen) = 0) then 1674 begin 1675 PosEx := i + SizeInt(Offset); 1676 Exit; 1677 end; 1678 //point Offset to next char in S 1679 Offset := sizeuint(i) + Offset + 1; 1680 i := indexword(S[Offset],Length(S) - Offset + 1, Word(SubFirst)); 1681 end; 1682 end; 1683end; 1684 1685function PosEx(c: WideChar; const S: UnicodeString; Offset: SizeUint): SizeInt; 1686var 1687 Len,p : SizeInt; 1688 1689begin 1690 Len := length(S); 1691 if (Offset < 1) or (Offset > SizeUInt(Length(S))) then exit(0); 1692 Len := length(S); 1693 p := indexword(S[Offset],Len-offset+1,Word(c)); 1694 if (p < 0) then 1695 PosEx := 0 1696 else 1697 PosEx := p + sizeint(Offset); 1698end; 1699 1700function PosEx(const SubStr, S: UnicodeString): Sizeint; // Offset: Cardinal = 1 1701begin 1702 PosEx:=PosEx(SubStr,S,1); 1703end; 1704 1705 1706function StringsReplace(const S: string; OldPattern, NewPattern: array of string; Flags: TReplaceFlags): string; 1707 1708var pc,pcc,lastpc : pchar; 1709 strcount : integer; 1710 ResStr, 1711 CompStr : string; 1712 Found : Boolean; 1713 sc : sizeint; 1714 1715begin 1716 sc := length(OldPattern); 1717 if sc <> length(NewPattern) then 1718 raise exception.Create(SErrAmountStrings); 1719 1720 dec(sc); 1721 1722 if rfIgnoreCase in Flags then 1723 begin 1724 CompStr:=AnsiUpperCase(S); 1725 for strcount := 0 to sc do 1726 OldPattern[strcount] := AnsiUpperCase(OldPattern[strcount]); 1727 end 1728 else 1729 CompStr := s; 1730 1731 ResStr := ''; 1732 pc := @CompStr[1]; 1733 pcc := @s[1]; 1734 lastpc := pc+Length(S); 1735 1736 while pc < lastpc do 1737 begin 1738 Found := False; 1739 for strcount := 0 to sc do 1740 begin 1741 if (length(OldPattern[strcount])>0) and 1742 (OldPattern[strcount][1]=pc^) and 1743 (Length(OldPattern[strcount]) <= (lastpc-pc)) and 1744 (CompareByte(OldPattern[strcount][1],pc^,Length(OldPattern[strcount]))=0) then 1745 begin 1746 ResStr := ResStr + NewPattern[strcount]; 1747 pc := pc+Length(OldPattern[strcount]); 1748 pcc := pcc+Length(OldPattern[strcount]); 1749 Found := true; 1750 end 1751 end; 1752 if not found then 1753 begin 1754 ResStr := ResStr + pcc^; 1755 inc(pc); 1756 inc(pcc); 1757 end 1758 else if not (rfReplaceAll in Flags) then 1759 begin 1760 ResStr := ResStr + StrPas(pcc); 1761 break; 1762 end; 1763 end; 1764 Result := ResStr; 1765end; 1766 1767{ --------------------------------------------------------------------- 1768 Delphi compat 1769 ---------------------------------------------------------------------} 1770 1771function ReplaceStr(const AText, AFromText, AToText: string): string; 1772begin 1773 result:=AnsiReplaceStr(AText, AFromText, AToText); 1774end; 1775 1776function ReplaceText(const AText, AFromText, AToText: string): string; 1777begin 1778 result:=AnsiReplaceText(AText, AFromText, AToText); 1779end; 1780 1781{ --------------------------------------------------------------------- 1782 Soundex Functions. 1783 ---------------------------------------------------------------------} 1784Const 1785 SScore : array[1..255] of Char = 1786 ('0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 1..32 1787 '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 33..64 1788 '0','1','2','3','0','1','2','i','0','2','2','4','5','5','0','1','2','6','2','3','0','1','i','2','i','2', // 65..90 1789 '0','0','0','0','0','0', // 91..96 1790 '0','1','2','3','0','1','2','i','0','2','2','4','5','5','0','1','2','6','2','3','0','1','i','2','i','2', // 97..122 1791 '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 123..154 1792 '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 155..186 1793 '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 187..218 1794 '0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0','0', // 219..250 1795 '0','0','0','0','0'); // 251..255 1796 1797function Soundex(const AText: string; ALength: TSoundexLength): string; 1798 1799Var 1800 S,PS : Char; 1801 I,L : SizeInt; 1802 1803begin 1804 Result:=''; 1805 PS:=#0; 1806 If Length(AText)>0 then 1807 begin 1808 Result:=Upcase(AText[1]); 1809 I:=2; 1810 L:=Length(AText); 1811 While (I<=L) and (Length(Result)<ALength) do 1812 begin 1813 S:=SScore[Ord(AText[i])]; 1814 If Not (S in ['0','i',PS]) then 1815 Result:=Result+S; 1816 If (S<>'i') then 1817 PS:=S; 1818 Inc(I); 1819 end; 1820 end; 1821 L:=Length(Result); 1822 If (L<ALength) then 1823 Result:=Result+StringOfChar('0',Alength-L); 1824end; 1825 1826 1827 1828function Soundex(const AText: string): string; // ; ALength: TSoundexLength = 4 1829 1830begin 1831 Result:=Soundex(AText,4); 1832end; 1833 1834Const 1835 Ord0 = Ord('0'); 1836 OrdA = Ord('A'); 1837 1838function SoundexInt(const AText: string; ALength: TSoundexIntLength): Integer; 1839 1840var 1841 SE: string; 1842 I: SizeInt; 1843 1844begin 1845 Result:=-1; 1846 SE:=Soundex(AText,ALength); 1847 If Length(SE)>0 then 1848 begin 1849 Result:=Ord(SE[1])-OrdA; 1850 if ALength > 1 then 1851 begin 1852 Result:=Result*26+(Ord(SE[2])-Ord0); 1853 for I:=3 to ALength do 1854 Result:=(Ord(SE[I])-Ord0)+Result*7; 1855 end; 1856 Result:=ALength+Result*9; 1857 end; 1858end; 1859 1860 1861function SoundexInt(const AText: string): Integer; //; ALength: TSoundexIntLength = 4 1862begin 1863 Result:=SoundexInt(AText,4); 1864end; 1865 1866 1867function DecodeSoundexInt(AValue: Integer): string; 1868 1869var 1870 I, Len: Integer; 1871 1872begin 1873 Result := ''; 1874 Len := AValue mod 9; 1875 AValue := AValue div 9; 1876 for I:=Len downto 3 do 1877 begin 1878 Result:=Chr(Ord0+(AValue mod 7))+Result; 1879 AValue:=AValue div 7; 1880 end; 1881 if Len>1 then 1882 begin 1883 Result:=Chr(Ord0+(AValue mod 26))+Result; 1884 AValue:=AValue div 26; 1885 end; 1886 Result:=Chr(OrdA+AValue)+Result; 1887end; 1888 1889 1890function SoundexWord(const AText: string): Word; 1891 1892Var 1893 S : String; 1894 1895begin 1896 S:=SoundEx(Atext,4); 1897 Result:=Ord(S[1])-OrdA; 1898 Result:=Result*26+ord(S[2])-48; 1899 Result:=Result*7+ord(S[3])-48; 1900 Result:=Result*7+ord(S[4])-48; 1901end; 1902 1903 1904function DecodeSoundexWord(AValue: Word): string; 1905begin 1906 Result := Chr(Ord0+ (AValue mod 7)); 1907 AValue := AValue div 7; 1908 Result := Chr(Ord0+ (AValue mod 7)) + Result; 1909 AValue := AValue div 7; 1910 Result := IntToStr(AValue mod 26) + Result; 1911 AValue := AValue div 26; 1912 Result := Chr(OrdA+AValue) + Result; 1913end; 1914 1915 1916function SoundexSimilar(const AText, AOther: string; ALength: TSoundexLength): Boolean; 1917begin 1918 Result:=Soundex(AText,ALength)=Soundex(AOther,ALength); 1919end; 1920 1921 1922function SoundexSimilar(const AText, AOther: string): Boolean; //; ALength: TSoundexLength = 4 1923begin 1924 Result:=SoundexSimilar(AText,AOther,4); 1925end; 1926 1927 1928function SoundexCompare(const AText, AOther: string; ALength: TSoundexLength): Integer; 1929begin 1930 Result:=AnsiCompareStr(Soundex(AText,ALength),Soundex(AOther,ALength)); 1931end; 1932 1933 1934function SoundexCompare(const AText, AOther: string): Integer; //; ALength: TSoundexLength = 4 1935begin 1936 Result:=SoundexCompare(AText,AOther,4); 1937end; 1938 1939 1940function SoundexProc(const AText, AOther: string): Boolean; 1941begin 1942 Result:=SoundexSimilar(AText,AOther); 1943end; 1944 1945{ --------------------------------------------------------------------- 1946 RxStrUtils-like functions. 1947 ---------------------------------------------------------------------} 1948 1949 1950function IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean; 1951 1952var 1953 i,l: SizeInt; 1954 1955begin 1956 l:=Length(S); 1957 i:=1; 1958 Result:=True; 1959 while Result and (i<=l) do 1960 begin 1961 Result:=(S[i] in EmptyChars); 1962 Inc(i); 1963 end; 1964end; 1965 1966function DelSpace(const S: string): string; 1967 1968begin 1969 Result:=DelChars(S,' '); 1970end; 1971 1972function DelChars(const S: string; Chr: Char): string; 1973 1974var 1975 I,J: SizeInt; 1976 1977begin 1978 Result:=S; 1979 I:=Length(Result); 1980 While I>0 do 1981 begin 1982 if Result[I]=Chr then 1983 begin 1984 J:=I-1; 1985 While (J>0) and (Result[J]=Chr) do 1986 Dec(j); 1987 Delete(Result,J+1,I-J); 1988 I:=J+1; 1989 end; 1990 dec(I); 1991 end; 1992end; 1993 1994function DelSpace1(const S: string): string; 1995 1996var 1997 I : SizeInt; 1998 1999begin 2000 Result:=S; 2001 for i:=Length(Result) downto 2 do 2002 if (Result[i]=' ') and (Result[I-1]=' ') then 2003 Delete(Result,I,1); 2004end; 2005 2006function Tab2Space(const S: string; Numb: Byte): string; 2007 2008var 2009 I: SizeInt; 2010 2011begin 2012 I:=1; 2013 Result:=S; 2014 while I <= Length(Result) do 2015 if Result[I]<>Chr(9) then 2016 inc(I) 2017 else 2018 begin 2019 Result[I]:=' '; 2020 If (Numb>1) then 2021 Insert(StringOfChar(' ',Numb-1),Result,I); 2022 Inc(I,Numb); 2023 end; 2024end; 2025 2026function NPos(const C: string; S: string; N: Integer): SizeInt; 2027 2028var 2029 i,p,k: SizeInt; 2030 2031begin 2032 Result:=0; 2033 if N<1 then 2034 Exit; 2035 k:=0; 2036 i:=1; 2037 Repeat 2038 p:=pos(C,S); 2039 Inc(k,p); 2040 if p>0 then 2041 delete(S,1,p); 2042 Inc(i); 2043 Until (i>n) or (p=0); 2044 If (P>0) then 2045 Result:=K; 2046end; 2047 2048function AddChar(C: Char; const S: string; N: Integer): string; 2049 2050Var 2051 l : SizeInt; 2052 2053begin 2054 Result:=S; 2055 l:=Length(Result); 2056 if l<N then 2057 Result:=StringOfChar(C,N-l)+Result; 2058end; 2059 2060function AddCharR(C: Char; const S: string; N: Integer): string; 2061 2062Var 2063 l : SizeInt; 2064 2065begin 2066 Result:=S; 2067 l:=Length(Result); 2068 if l<N then 2069 Result:=Result+StringOfChar(C,N-l); 2070end; 2071 2072 2073function PadRight(const S: string; N: Integer): string;inline; 2074begin 2075 Result:=AddCharR(' ',S,N); 2076end; 2077 2078 2079function PadLeft(const S: string; N: Integer): string;inline; 2080begin 2081 Result:=AddChar(' ',S,N); 2082end; 2083 2084 2085function Copy2Symb(const S: string; Symb: Char): string; 2086 2087var 2088 p: SizeInt; 2089 2090begin 2091 p:=Pos(Symb,S); 2092 if p=0 then 2093 p:=Length(S)+1; 2094 Result:=Copy(S,1,p-1); 2095end; 2096 2097function Copy2SymbDel(var S: string; Symb: Char): string; 2098 2099var 2100 p: SizeInt; 2101 2102begin 2103 p:=Pos(Symb,S); 2104 if p=0 then 2105 begin 2106 result:=s; 2107 s:=''; 2108 end 2109 else 2110 begin 2111 Result:=Copy(S,1,p-1); 2112 delete(s,1,p); 2113 end; 2114end; 2115 2116function Copy2Space(const S: string): string;inline; 2117begin 2118 Result:=Copy2Symb(S,' '); 2119end; 2120 2121function Copy2SpaceDel(var S: string): string;inline; 2122begin 2123 Result:=Copy2SymbDel(S,' '); 2124end; 2125 2126function AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string; 2127 2128var 2129 P,PE : PChar; 2130 2131begin 2132 Result:=AnsiLowerCase(S); 2133 P:=PChar(pointer(Result)); 2134 PE:=P+Length(Result); 2135 while (P<PE) do 2136 begin 2137 while (P<PE) and (P^ in WordDelims) do 2138 inc(P); 2139 if (P<PE) then 2140 P^:=UpCase(P^); 2141 while (P<PE) and not (P^ in WordDelims) do 2142 inc(P); 2143 end; 2144end; 2145 2146function WordCount(const S: string; const WordDelims: TSysCharSet): SizeInt; 2147 2148var 2149 P,PE : PChar; 2150 2151begin 2152 Result:=0; 2153 P:=Pchar(pointer(S)); 2154 PE:=P+Length(S); 2155 while (P<PE) do 2156 begin 2157 while (P<PE) and (P^ in WordDelims) do 2158 Inc(P); 2159 if (P<PE) then 2160 inc(Result); 2161 while (P<PE) and not (P^ in WordDelims) do 2162 inc(P); 2163 end; 2164end; 2165 2166function WordPosition(const N: Integer; const S: string; const WordDelims: TSysCharSet): SizeInt; 2167 2168var 2169 PS,P,PE : PChar; 2170 Count: Integer; 2171 2172begin 2173 Result:=0; 2174 Count:=0; 2175 PS:=PChar(pointer(S)); 2176 PE:=PS+Length(S); 2177 P:=PS; 2178 while (P<PE) and (Count<>N) do 2179 begin 2180 while (P<PE) and (P^ in WordDelims) do 2181 inc(P); 2182 if (P<PE) then 2183 inc(Count); 2184 if (Count<>N) then 2185 while (P<PE) and not (P^ in WordDelims) do 2186 inc(P) 2187 else 2188 Result:=(P-PS)+1; 2189 end; 2190end; 2191 2192 2193function ExtractWord(N: Integer; const S: string; const WordDelims: TSysCharSet): string;inline; 2194var 2195 i: SizeInt; 2196begin 2197 Result:=ExtractWordPos(N,S,WordDelims,i); 2198end; 2199 2200 2201function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; out Pos: Integer): string; 2202 2203var 2204 i,j,l: SizeInt; 2205 2206begin 2207 j:=0; 2208 i:=WordPosition(N, S, WordDelims); 2209 if (I>High(Integer)) then 2210 begin 2211 Result:=''; 2212 Pos:=-1; 2213 Exit; 2214 end; 2215 Pos:=i; 2216 if (i<>0) then 2217 begin 2218 j:=i; 2219 l:=Length(S); 2220 while (j<=L) and not (S[j] in WordDelims) do 2221 inc(j); 2222 end; 2223 SetLength(Result,j-i); 2224 If ((j-i)>0) then 2225 Move(S[i],Result[1],j-i); 2226end; 2227 2228{$IF SIZEOF(SIZEINT)<>SIZEOF(INTEGER)} 2229function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; Out Pos: SizeInt): string; 2230var 2231 i,j,l: SizeInt; 2232 2233begin 2234 j:=0; 2235 i:=WordPosition(N, S, WordDelims); 2236 Pos:=i; 2237 if (i<>0) then 2238 begin 2239 j:=i; 2240 l:=Length(S); 2241 while (j<=L) and not (S[j] in WordDelims) do 2242 inc(j); 2243 end; 2244 SetLength(Result,j-i); 2245 If ((j-i)>0) then 2246 Move(S[i],Result[1],j-i); 2247end; 2248{$ENDIF} 2249 2250function ExtractDelimited(N: Integer; const S: string; const Delims: TSysCharSet): string; 2251var 2252 w,i,l,len: SizeInt; 2253begin 2254 w:=0; 2255 i:=1; 2256 l:=0; 2257 len:=Length(S); 2258 SetLength(Result, 0); 2259 while (i<=len) and (w<>N) do 2260 begin 2261 if s[i] in Delims then 2262 inc(w) 2263 else 2264 begin 2265 if (N-1)=w then 2266 begin 2267 inc(l); 2268 SetLength(Result,l); 2269 Result[L]:=S[i]; 2270 end; 2271 end; 2272 inc(i); 2273 end; 2274end; 2275 2276{$IF SIZEOF(SIZEINT)<>SIZEOF(INTEGER)} 2277function ExtractSubstr(const S: string; var Pos: SizeInt; const Delims: TSysCharSet): string; 2278 2279var 2280 i,l: SizeInt; 2281 2282begin 2283 i:=Pos; 2284 l:=Length(S); 2285 while (i<=l) and not (S[i] in Delims) do 2286 inc(i); 2287 Result:=Copy(S,Pos,i-Pos); 2288 while (i<=l) and (S[i] in Delims) do 2289 inc(i); 2290 Pos:=i; 2291end; 2292{$ENDIF} 2293 2294function ExtractSubstr(const S: string; var Pos: Integer; const Delims: TSysCharSet): string; 2295 2296var 2297 i,l: SizeInt; 2298 2299begin 2300 i:=Pos; 2301 l:=Length(S); 2302 while (i<=l) and not (S[i] in Delims) do 2303 inc(i); 2304 Result:=Copy(S,Pos,i-Pos); 2305 while (i<=l) and (S[i] in Delims) do 2306 inc(i); 2307 if I>MaxInt then 2308 Pos:=MaxInt 2309 else 2310 Pos:=i; 2311end; 2312 2313function IsWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean; 2314 2315var 2316 i,Count : SizeInt; 2317 2318begin 2319 Result:=False; 2320 Count:=WordCount(S, WordDelims); 2321 I:=1; 2322 While (Not Result) and (I<=Count) do 2323 begin 2324 Result:=ExtractWord(i,S,WordDelims)=W; 2325 Inc(i); 2326 end; 2327end; 2328 2329 2330function Numb2USA(const S: string): string; 2331var 2332 i, NA: Integer; 2333begin 2334 i:=Length(S); 2335 Result:=S; 2336 NA:=0; 2337 while (i > 0) do begin 2338 if ((Length(Result) - i + 1 - NA) mod 3 = 0) and (i <> 1) then 2339 begin 2340 insert(',', Result, i); 2341 inc(NA); 2342 end; 2343 Dec(i); 2344 end; 2345end; 2346 2347function PadCenter(const S: string; Len: SizeInt): string; 2348begin 2349 if Length(S)<Len then 2350 begin 2351 Result:=StringOfChar(' ',(Len div 2) -(Length(S) div 2))+S; 2352 Result:=Result+StringOfChar(' ',Len-Length(Result)); 2353 end 2354 else 2355 Result:=S; 2356end; 2357 2358 2359function Dec2Numb(N: Longint; Len, Base: Byte): string; 2360 2361var 2362 C: Integer; 2363 Number: Longint; 2364 2365begin 2366 if N=0 then 2367 Result:='0' 2368 else 2369 begin 2370 Number:=N; 2371 Result:=''; 2372 while Number>0 do 2373 begin 2374 C:=Number mod Base; 2375 if C>9 then 2376 C:=C+55 2377 else 2378 C:=C+48; 2379 Result:=Chr(C)+Result; 2380 Number:=Number div Base; 2381 end; 2382 end; 2383 if (Result<>'') then 2384 Result:=AddChar('0',Result,Len); 2385end; 2386 2387function Numb2Dec(S: string; Base: Byte): Longint; 2388 2389var 2390 i, P: sizeint; 2391 2392begin 2393 i:=Length(S); 2394 Result:=0; 2395 S:=UpperCase(S); 2396 P:=1; 2397 while (i>=1) do 2398 begin 2399 if (S[i]>'@') then 2400 Result:=Result+(Ord(S[i])-55)*P 2401 else 2402 Result:=Result+(Ord(S[i])-48)*P; 2403 Dec(i); 2404 P:=P*Base; 2405 end; 2406end; 2407 2408 2409function RomanToIntDontCare(const S: String): Longint; 2410{This was the original implementation of RomanToInt, 2411 it is internally used in TryRomanToInt when Strictness = rcsDontCare} 2412const 2413 RomanChars = ['C','D','I','L','M','V','X']; 2414 RomanValues : array['C'..'X'] of Word 2415 = (100,500,0,0,0,0,1,0,0,50,1000,0,0,0,0,0,0,0,0,5,0,10); 2416 2417var 2418 index, Next: Char; 2419 i,l: SizeInt; 2420 Negative: Boolean; 2421 2422begin 2423 Result:=0; 2424 i:=0; 2425 Negative:=(Length(S)>0) and (S[1]='-'); 2426 if Negative then 2427 inc(i); 2428 l:=Length(S); 2429 while (i<l) do 2430 begin 2431 inc(i); 2432 index:=UpCase(S[i]); 2433 if index in RomanChars then 2434 begin 2435 if Succ(i)<=l then 2436 Next:=UpCase(S[i+1]) 2437 else 2438 Next:=#0; 2439 if (Next in RomanChars) and (RomanValues[index]<RomanValues[Next]) then 2440 begin 2441 inc(Result, RomanValues[Next]); 2442 Dec(Result, RomanValues[index]); 2443 inc(i); 2444 end 2445 else 2446 inc(Result, RomanValues[index]); 2447 end 2448 else 2449 begin 2450 Result:=0; 2451 Exit; 2452 end; 2453 end; 2454 if Negative then 2455 Result:=-Result; 2456end; 2457 2458 2459{ TryRomanToInt: try to convert a roman numeral to an integer 2460 Parameters: 2461 S: Roman numeral (like: 'MCMXXII') 2462 N: Integer value of S (only meaningfull if the function succeeds) 2463 Stricness: controls how strict the parsing of S is 2464 - rcsStrict: 2465 * Follow common subtraction rules 2466 - only 1 preceding subtraction character allowed: IX = 9, but IIX <> 8 2467 - from M you can only subtract C 2468 - from D you can only subtract C 2469 - from C you can only subtract X 2470 - from L you can only subtract X 2471 - from X you can only subtract I 2472 - from V you can only subtract I 2473 * The numeral is parsed in "groups" (first M's, then D's etc.), the next group to be parsed 2474 must always be of a lower denomination than the previous one. 2475 Example: 'MMDCCXX' is allowed but 'MMCCXXDD' is not 2476 * There can only ever be 3 consecutive M's, C's, X's or I's 2477 * There can only ever be 1 D, 1 L and 1 V 2478 * After IX or IV there can be no more characters 2479 * Negative numbers are not supported 2480 // As a consequence the maximum allowed Roman numeral is MMMCMXCIX = 3999, also N can never become 0 (zero) 2481 2482 - rcsRelaxed: Like rcsStrict but with the following exceptions: 2483 * An infinite number of (leading) M's is allowed 2484 * Up to 4 consecutive M's, C's, X's and I's are allowed 2485 // So this is allowed: 'MMMMMMCXIIII' = 6124 2486 2487 - rcsDontCare: 2488 * no checking on the order of "groups" is done 2489 * there are no restrictions on the number of consecutive chars 2490 * negative numbers are supported 2491 * an empty string as input will return True and N will be 0 2492 * invalid input will return false 2493 // for backwards comatibility: it supports rather ludicrous input like '-IIIMIII' -> -(2+(1000-1)+3)=-1004 2494} 2495 2496function TryRomanToInt(S: String; out N: LongInt; Strictness: TRomanConversionStrictness = rcsRelaxed): Boolean; 2497 2498var 2499 i, Len: SizeInt; 2500 Terminated: Boolean; 2501 2502begin 2503 Result := (False); 2504 S := UpperCase(S); //don't use AnsiUpperCase please 2505 Len := Length(S); 2506 if (Strictness = rcsDontCare) then 2507 begin 2508 N := RomanToIntDontCare(S); 2509 if (N = 0) then 2510 begin 2511 Result := (Len = 0); 2512 end 2513 else 2514 Result := True; 2515 Exit; 2516 end; 2517 if (Len = 0) then 2518 begin 2519 Result:=true; 2520 N:=0; 2521 Exit; 2522 end; 2523 i := 1; 2524 N := 0; 2525 Terminated := False; 2526 //leading M's 2527 while (i <= Len) and ((Strictness <> rcsStrict) or (i < 4)) and (S[i] = 'M') do 2528 begin 2529 //writeln('TryRomanToInt: Found 1000'); 2530 Inc(i); 2531 N := N + 1000; 2532 end; 2533 //then CM or or CD or D or (C, CC, CCC, CCCC) 2534 if (i <= Len) and (S[i] = 'D') then 2535 begin 2536 //writeln('TryRomanToInt: Found 500'); 2537 Inc(i); 2538 N := N + 500; 2539 end 2540 else if (i + 1 <= Len) and (S[i] = 'C') then 2541 begin 2542 if (S[i+1] = 'M') then 2543 begin 2544 //writeln('TryRomanToInt: Found 900'); 2545 Inc(i,2); 2546 N := N + 900; 2547 end 2548 else if (S[i+1] = 'D') then 2549 begin 2550 //writeln('TryRomanToInt: Found 400'); 2551 Inc(i,2); 2552 N := N + 400; 2553 end; 2554 end ; 2555 //next max 4 or 3 C's, depending on Strictness 2556 if (i <= Len) and (S[i] = 'C') then 2557 begin 2558 //find max 4 C's 2559 //writeln('TryRomanToInt: Found 100'); 2560 Inc(i); 2561 N := N + 100; 2562 if (i <= Len) and (S[i] = 'C') then 2563 begin 2564 //writeln('TryRomanToInt: Found 100'); 2565 Inc(i); 2566 N := N + 100; 2567 end; 2568 if (i <= Len) and (S[i] = 'C') then 2569 begin 2570 //writeln('TryRomanToInt: Found 100'); 2571 Inc(i); 2572 N := N + 100; 2573 end; 2574 if (Strictness <> rcsStrict) and (i <= Len) and (S[i] = 'C') then 2575 begin 2576 //writeln('TryRomanToInt: Found 100'); 2577 Inc(i); 2578 N := N + 100; 2579 end; 2580 end; 2581 2582 //then XC or XL 2583 if (i + 1 <= Len) and (S[i] = 'X') then 2584 begin 2585 if (S[i+1] = 'C') then 2586 begin 2587 //writeln('TryRomanToInt: Found 90'); 2588 Inc(i,2); 2589 N := N + 90; 2590 end 2591 else if (S[i+1] = 'L') then 2592 begin 2593 //writeln('TryRomanToInt: Found 40'); 2594 Inc(i,2); 2595 N := N + 40; 2596 end; 2597 end; 2598 2599 //then L 2600 if (i <= Len) and (S[i] = 'L') then 2601 begin 2602 //writeln('TryRomanToInt: Found 50'); 2603 Inc(i); 2604 N := N + 50; 2605 end; 2606 2607 //then (X, xx, xxx, xxxx) 2608 if (i <= Len) and (S[i] = 'X') then 2609 begin 2610 //find max 3 or 4 X's, depending on Strictness 2611 //writeln('TryRomanToInt: Found 10'); 2612 Inc(i); 2613 N := N + 10; 2614 if (i <= Len) and (S[i] = 'X') then 2615 begin 2616 //writeln('TryRomanToInt: Found 10'); 2617 Inc(i); 2618 N := N + 10; 2619 end; 2620 if (i <= Len) and (S[i] = 'X') then 2621 begin 2622 //writeln('TryRomanToInt: Found 10'); 2623 Inc(i); 2624 N := N + 10; 2625 end; 2626 if (Strictness <> rcsStrict) and (i <= Len) and (S[i] = 'X') then 2627 begin 2628 //writeln('TryRomanToInt: Found 10'); 2629 Inc(i); 2630 N := N + 10; 2631 end; 2632 end; 2633 2634 //then IX or IV 2635 if (i + 1 <= Len) and (S[i] = 'I') then 2636 begin 2637 if (S[i+1] = 'X') then 2638 begin 2639 Terminated := (True); 2640 //writeln('TryRomanToInt: Found 9'); 2641 Inc(i,2); 2642 N := N + 9; 2643 end 2644 else if (S[i+1] = 'V') then 2645 begin 2646 Terminated := (True); 2647 //writeln('TryRomanToInt: Found 4'); 2648 Inc(i,2); 2649 N := N + 4; 2650 end; 2651 end; 2652 2653 //then V 2654 if (not Terminated) and (i <= Len) and (S[i] = 'V') then 2655 begin 2656 //writeln('TryRomanToInt: Found 5'); 2657 Inc(i); 2658 N := N + 5; 2659 end; 2660 2661 2662 //then I 2663 if (not Terminated) and (i <= Len) and (S[i] = 'I') then 2664 begin 2665 Terminated := (True); 2666 //writeln('TryRomanToInt: Found 1'); 2667 Inc(i); 2668 N := N + 1; 2669 //Find max 2 or 3 closing I's, depending on strictness 2670 if (i <= Len) and (S[i] = 'I') then 2671 begin 2672 //writeln('TryRomanToInt: Found 1'); 2673 Inc(i); 2674 N := N + 1; 2675 end; 2676 if (i <= Len) and (S[i] = 'I') then 2677 begin 2678 //writeln('TryRomanToInt: Found 1'); 2679 Inc(i); 2680 N := N + 1; 2681 end; 2682 if (Strictness <> rcsStrict) and (i <= Len) and (S[i] = 'I') then 2683 begin 2684 //writeln('TryRomanToInt: Found 1'); 2685 Inc(i); 2686 N := N + 1; 2687 end; 2688 end; 2689 2690 //writeln('TryRomanToInt: Len = ',Len,' i = ',i); 2691 Result := (i > Len); 2692 //if Result then writeln('TryRomanToInt: N = ',N); 2693 2694end; 2695 2696function RomanToInt(const S: string; Strictness: TRomanConversionStrictness = rcsRelaxed): Longint; 2697begin 2698 if not TryRomanToInt(S, Result, Strictness) then 2699 raise EConvertError.CreateFmt(SInvalidRomanNumeral,[S]); 2700end; 2701 2702function RomanToIntDef(const S: String; const ADefault: Longint; 2703 Strictness: TRomanConversionStrictness): Longint; 2704begin 2705 if not TryRomanToInt(S, Result, Strictness) then 2706 Result := ADefault; 2707end; 2708 2709 2710 2711 2712function IntToRoman(Value: Longint): string; 2713 2714const 2715 Arabics : Array[1..13] of Integer 2716 = (1,4,5,9,10,40,50,90,100,400,500,900,1000); 2717 Romans : Array[1..13] of String 2718 = ('I','IV','V','IX','X','XL','L','XC','C','CD','D','CM','M'); 2719 2720var 2721 i: Integer; 2722 2723begin 2724 Result:=''; 2725 for i:=13 downto 1 do 2726 while (Value >= Arabics[i]) do 2727 begin 2728 Value:=Value-Arabics[i]; 2729 Result:=Result+Romans[i]; 2730 end; 2731end; 2732 2733function IntToBin(Value: Longint; Digits, Spaces: Integer): string; 2734var endpos : integer; 2735 p,p2:pchar; 2736 k: integer; 2737begin 2738 Result:=''; 2739 if (Digits>32) then 2740 Digits:=32; 2741 if (spaces=0) then 2742 begin 2743 result:=inttobin(value,digits); 2744 exit; 2745 end; 2746 endpos:=digits+ (digits-1) div spaces; 2747 setlength(result,endpos); 2748 p:=@result[endpos]; 2749 p2:=@result[1]; 2750 k:=spaces; 2751 while (p>=p2) do 2752 begin 2753 if k=0 then 2754 begin 2755 p^:=' '; 2756 dec(p); 2757 k:=spaces; 2758 end; 2759 p^:=chr(48+(cardinal(value) and 1)); 2760 value:=cardinal(value) shr 1; 2761 dec(p); 2762 dec(k); 2763 end; 2764end; 2765 2766function IntToBin(Value: Longint; Digits: Integer): string; 2767var p,p2 : pchar; 2768begin 2769 result:=''; 2770 if digits<=0 then exit; 2771 setlength(result,digits); 2772 p:=pchar(pointer(@result[digits])); 2773 p2:=pchar(pointer(@result[1])); 2774 // typecasts because we want to keep intto* delphi compat and take an integer 2775 while (p>=p2) and (cardinal(value)>0) do 2776 begin 2777 p^:=chr(48+(cardinal(value) and 1)); 2778 value:=cardinal(value) shr 1; 2779 dec(p); 2780 end; 2781 digits:=p-p2+1; 2782 if digits>0 then 2783 fillchar(result[1],digits,#48); 2784end; 2785 2786function intToBin(Value: int64; Digits:integer): string; 2787var p,p2 : pchar; 2788begin 2789 result:=''; 2790 if digits<=0 then exit; 2791 setlength(result,digits); 2792 p:=pchar(pointer(@result[digits])); 2793 p2:=pchar(pointer(@result[1])); 2794 // typecasts because we want to keep intto* delphi compat and take a signed val 2795 // and avoid warnings 2796 while (p>=p2) and (qword(value)>0) do 2797 begin 2798 p^:=chr(48+(cardinal(value) and 1)); 2799 value:=qword(value) shr 1; 2800 dec(p); 2801 end; 2802 digits:=p-p2+1; 2803 if digits>0 then 2804 fillchar(result[1],digits,#48); 2805end; 2806 2807 2808function FindPart(const HelpWilds, InputStr: string): SizeInt; 2809var 2810 Diff, i, J: SizeInt; 2811 2812begin 2813 Result:=0; 2814 i:=Pos('?',HelpWilds); 2815 if (i=0) then 2816 Result:=Pos(HelpWilds, inputStr) 2817 else 2818 begin 2819 Diff:=Length(inputStr) - Length(HelpWilds); 2820 for i:=0 to Diff do 2821 begin 2822 for J:=1 to Length(HelpWilds) do 2823 if (inputStr[i + J] = HelpWilds[J]) or (HelpWilds[J] = '?') then 2824 begin 2825 if (J=Length(HelpWilds)) then 2826 begin 2827 Result:=i+1; 2828 Exit; 2829 end; 2830 end 2831 else 2832 Break; 2833 end; 2834 end; 2835end; 2836 2837Function isMatch(level : integer;inputstr,wilds : string; CWild, CinputWord: SizeInt;MaxInputword,maxwilds : SizeInt; Out EOS : Boolean) : Boolean; 2838 2839 function WildisQuestionmark : boolean; 2840begin 2841 Result:=CWild <= MaxWilds; 2842 if Result then 2843 Result:= Wilds[CWild]='?'; 2844 end; 2845 2846 function WildisStar : boolean; 2847 begin 2848 Result:=CWild <= MaxWilds; 2849 if Result then 2850 Result:= Wilds[CWild]='*'; 2851 end; 2852 2853begin 2854 EOS:=False; 2855 Result:=True; 2856 repeat 2857 if WildisStar then { handling of '*' } 2858 begin 2859 inc(CWild); 2860 if CWild>MaxWilds then 2861 begin 2862 EOS:=true; 2863 exit; 2864 end; 2865 while WildisQuestionmark do { equal to '?' } 2866 begin 2867 { goto next letter } 2868 inc(CWild); 2869 inc(CinputWord); 2870 end; 2871 { increase until a match } 2872 Repeat 2873 while (CinputWord <= MaxinputWord) and (CWild <= MaxWilds) and (inputStr[CinputWord]<>Wilds[CWild]) do 2874 inc(CinputWord); 2875 Result:=isMatch(Level+1,inputstr,wilds,CWild, CinputWord,MaxInputword,maxwilds,EOS); 2876 if not Result then 2877 Inc(cInputWord); 2878 Until Result or (CinputWord>=MaxinputWord); 2879 if Result and EOS then 2880 Exit; 2881 Continue; 2882 end; 2883 if WildisQuestionmark then { equal to '?' } 2884 begin 2885 { goto next letter } 2886 inc(CWild); 2887 inc(CinputWord); 2888 Continue; 2889 end; 2890 if (CinputWord>MaxinputWord) or (CWild > MaxWilds) or (inputStr[CinputWord] = Wilds[CWild]) then { equal letters } 2891 begin 2892 { goto next letter } 2893 inc(CWild); 2894 inc(CinputWord); 2895 Continue; 2896 end; 2897 Result:=false; 2898 Exit; 2899 until (CinputWord > MaxinputWord) or (CWild > MaxWilds); 2900 { no completed evaluation, we need to check what happened } 2901 if (CinputWord <= MaxinputWord) or (CWild < MaxWilds) then 2902 Result:=false 2903 else if (CWild>Maxwilds) then 2904 EOS:=False 2905 else 2906 begin 2907 EOS:=Wilds[CWild]='*'; 2908 if not EOS then 2909 Result:=False; 2910 end 2911end; 2912 2913function IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean; 2914 2915var 2916 i: SizeInt; 2917 MaxinputWord, MaxWilds: SizeInt; { Length of inputStr and Wilds } 2918 eos : Boolean; 2919 2920begin 2921 Result:=true; 2922 if Wilds = inputStr then 2923 Exit; 2924 { delete '**', because '**' = '*' } 2925 i:=Pos('**', Wilds); 2926 while i > 0 do 2927 begin 2928 Delete(Wilds, i, 1); 2929 i:=Pos('**', Wilds); 2930 end; 2931 if Wilds = '*' then { for fast end, if Wilds only '*' } 2932 Exit; 2933 MaxinputWord:=Length(inputStr); 2934 MaxWilds:=Length(Wilds); 2935 if (MaxWilds = 0) or (MaxinputWord = 0) then 2936 begin 2937 Result:=false; 2938 Exit; 2939 end; 2940 if ignoreCase then { upcase all letters } 2941 begin 2942 inputStr:=AnsiUpperCase(inputStr); 2943 Wilds:=AnsiUpperCase(Wilds); 2944 end; 2945 Result:=isMatch(1,inputStr,wilds,1,1,MaxinputWord, MaxWilds,EOS); 2946end; 2947 2948 2949function XorString(const Key, Src: ShortString): ShortString; 2950var 2951 i: SizeInt; 2952begin 2953 Result:=Src; 2954 if Length(Key) > 0 then 2955 for i:=1 to Length(Src) do 2956 Result[i]:=Chr(Byte(Key[1 + ((i - 1) mod Length(Key))]) xor Ord(Src[i])); 2957end; 2958 2959function XorEncode(const Key, Source: string): string; 2960 2961var 2962 i: Integer; 2963 C: Byte; 2964 2965begin 2966 Result:=''; 2967 for i:=1 to Length(Source) do 2968 begin 2969 if Length(Key) > 0 then 2970 C:=Byte(Key[1 + ((i - 1) mod Length(Key))]) xor Byte(Source[i]) 2971 else 2972 C:=Byte(Source[i]); 2973 Result:=Result+AnsiLowerCase(intToHex(C, 2)); 2974 end; 2975end; 2976 2977function XorDecode(const Key, Source: string): string; 2978var 2979 i: Integer; 2980 C: Char; 2981begin 2982 Result:=''; 2983 for i:=0 to Length(Source) div 2 - 1 do 2984 begin 2985 C:=Chr(StrTointDef('$' + Copy(Source, (i * 2) + 1, 2), Ord(' '))); 2986 if Length(Key) > 0 then 2987 C:=Chr(Byte(Key[1 + (i mod Length(Key))]) xor Byte(C)); 2988 Result:=Result + C; 2989 end; 2990end; 2991 2992function GetCmdLineArg(const Switch: string; SwitchChars: TSysCharSet): string; 2993var 2994 i: Integer; 2995 S: string; 2996begin 2997 i:=1; 2998 Result:=''; 2999 while (Result='') and (i<=ParamCount) do 3000 begin 3001 S:=ParamStr(i); 3002 if (SwitchChars=[]) or ((S[1] in SwitchChars) and (Length(S) > 1)) and 3003 (AnsiCompareText(Copy(S,2,Length(S)-1),Switch)=0) then 3004 begin 3005 inc(i); 3006 if i<=ParamCount then 3007 Result:=ParamStr(i); 3008 end; 3009 inc(i); 3010 end; 3011end; 3012 3013function RPosEX(C: char; const S: AnsiString; offs: cardinal): SizeInt; 3014 3015var I : SizeUInt; 3016 p,p2: pChar; 3017 3018Begin 3019 I:=Length(S); 3020 If (I<>0) and (offs<=i) Then 3021 begin 3022 p:=@s[offs]; 3023 p2:=@s[1]; 3024 while (p2<=p) and (p^<>c) do dec(p); 3025 RPosEx:=(p-p2)+1; 3026 end 3027 else 3028 RPosEX:=0; 3029End; 3030 3031function RPos(c: char; const S: AnsiString): SizeInt; 3032 3033var I : SizeInt; 3034 p,p2: pChar; 3035 3036Begin 3037 I:=Length(S); 3038 If I<>0 Then 3039 begin 3040 p:=@s[i]; 3041 p2:=@s[1]; 3042 while (p2<=p) and (p^<>c) do dec(p); 3043 i:=p-p2+1; 3044 end; 3045 RPos:=i; 3046End; 3047 3048function RPos(const Substr: AnsiString; const Source: AnsiString): SizeInt; 3049var 3050 MaxLen,llen : SizeInt; 3051 c : char; 3052 pc,pc2 : pchar; 3053begin 3054 rPos:=0; 3055 llen:=Length(SubStr); 3056 maxlen:=length(source); 3057 if (llen>0) and (maxlen>0) and ( llen<=maxlen) then 3058 begin 3059 // i:=maxlen; 3060 pc:=@source[maxlen]; 3061 pc2:=@source[llen-1]; 3062 c:=substr[llen]; 3063 while pc>=pc2 do 3064 begin 3065 if (c=pc^) and 3066 (CompareChar(Substr[1],pchar(pc-llen+1)^,Length(SubStr))=0) then 3067 begin 3068 rPos:=pchar(pc-llen+1)-pchar(@source[1])+1; 3069 exit; 3070 end; 3071 dec(pc); 3072 end; 3073 end; 3074end; 3075 3076function RPosex(const Substr: AnsiString; const Source: AnsiString; offs: cardinal): SizeInt; 3077var 3078 MaxLen,llen : SizeInt; 3079 c : char; 3080 pc,pc2 : pchar; 3081begin 3082 rPosex:=0; 3083 llen:=Length(SubStr); 3084 maxlen:=length(source); 3085 if SizeInt(offs)<maxlen then maxlen:=offs; 3086 if (llen>0) and (maxlen>0) and ( llen<=maxlen) then 3087 begin 3088// i:=maxlen; 3089 pc:=@source[maxlen]; 3090 pc2:=@source[llen-1]; 3091 c:=substr[llen]; 3092 while pc>=pc2 do 3093 begin 3094 if (c=pc^) and 3095 (CompareChar(Substr[1],pchar(pc-llen+1)^,Length(SubStr))=0) then 3096 begin 3097 rPosex:=pchar(pc-llen+1)-pchar(@source[1])+1; 3098 exit; 3099 end; 3100 dec(pc); 3101 end; 3102 end; 3103end; 3104 3105function RPosEX(C: unicodechar; const S: UnicodeString; offs: cardinal): SizeInt; 3106 3107var I : SizeUInt; 3108 p,p2: PUnicodeChar; 3109 3110Begin 3111 I:=Length(S); 3112 If (I<>0) and (offs<=i) Then 3113 begin 3114 p:=@s[offs]; 3115 p2:=@s[1]; 3116 while (p2<=p) and (p^<>c) do dec(p); 3117 RPosEx:=(p-p2)+1; 3118 end 3119 else 3120 RPosEX:=0; 3121End; 3122 3123function RPos(c: Unicodechar; const S: UnicodeString): SizeInt; 3124 3125var I : SizeInt; 3126 p,p2: pUnicodeChar; 3127 3128Begin 3129 I:=Length(S); 3130 If I<>0 Then 3131 begin 3132 p:=@s[i]; 3133 p2:=@s[1]; 3134 while (p2<=p) and (p^<>c) do dec(p); 3135 i:=p-p2+1; 3136 end; 3137 RPos:=i; 3138End; 3139 3140function RPos(const Substr: UnicodeString; const Source: UnicodeString): SizeInt; 3141var 3142 MaxLen,llen : SizeInt; 3143 c : Unicodechar; 3144 pc,pc2 : PUnicodechar; 3145begin 3146 rPos:=0; 3147 llen:=Length(SubStr); 3148 maxlen:=length(source); 3149 if (llen>0) and (maxlen>0) and ( llen<=maxlen) then 3150 begin 3151 pc:=@source[maxlen]; 3152 pc2:=@source[llen-1]; 3153 c:=substr[llen]; 3154 while pc>=pc2 do 3155 begin 3156 if (c=pc^) and 3157 (CompareWord(Substr[1],punicodechar(pc-llen+1)^,Length(SubStr))=0) then 3158 begin 3159 rPos:=punicodechar(pc-llen+1)-punicodechar(@source[1])+1; 3160 exit; 3161 end; 3162 dec(pc); 3163 end; 3164 end; 3165end; 3166 3167function RPosex(const Substr: UnicodeString; const Source: UnicodeString; offs: cardinal): SizeInt; 3168var 3169 MaxLen,llen : SizeInt; 3170 c : unicodechar; 3171 pc,pc2 : punicodechar; 3172begin 3173 rPosex:=0; 3174 llen:=Length(SubStr); 3175 maxlen:=length(source); 3176 if SizeInt(offs)<maxlen then maxlen:=offs; 3177 if (llen>0) and (maxlen>0) and ( llen<=maxlen) then 3178 begin 3179 pc:=@source[maxlen]; 3180 pc2:=@source[llen-1]; 3181 c:=substr[llen]; 3182 while pc>=pc2 do 3183 begin 3184 if (c=pc^) and 3185 (Compareword(Substr[1],punicodechar(pc-llen+1)^,Length(SubStr))=0) then 3186 begin 3187 rPosex:=punicodechar(pc-llen+1)-punicodechar(@source[1])+1; 3188 exit; 3189 end; 3190 dec(pc); 3191 end; 3192 end; 3193end; 3194 3195// def from delphi.about.com: 3196(* 3197procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer); 3198 3199Const 3200 HexDigits='0123456789ABCDEF'; 3201var 3202 i : longint; 3203begin 3204 for i:=0 to binbufsize-1 do 3205 begin 3206 HexValue[0]:=hexdigits[1+((ord(binvalue^) shr 4))]; 3207 HexValue[1]:=hexdigits[1+((ord(binvalue^) and 15))]; 3208 inc(hexvalue,2); 3209 inc(binvalue); 3210 end; 3211end; 3212*) 3213 3214procedure BinToHex(BinValue: PAnsiChar; HexValue: PAnsiChar; BinBufSize: Integer); 3215const 3216 HexDigits : AnsiString='0123456789ABCDEF'; 3217 var 3218 i : longint; 3219 begin 3220 for i:=0 to BinBufSize-1 do 3221 begin 3222 HexValue[0]:=HexDigits[1+((Ord(BinValue[i]) shr 4))]; 3223 HexValue[1]:=HexDigits[1+((Ord(BinValue[i]) and 15))]; 3224 Inc(HexValue,2); 3225 end; 3226end; 3227 3228procedure BinToHex(BinValue: PAnsiChar; HexValue: PWideChar; BinBufSize: Integer); 3229const 3230 HexDigits : WideString='0123456789ABCDEF'; 3231var 3232 i : longint; 3233begin 3234 for i:=0 to BinBufSize-1 do 3235 begin 3236 HexValue[0]:=HexDigits[1+((Ord(BinValue[i]) shr 4))]; 3237 HexValue[1]:=HexDigits[1+((Ord(BinValue[i]) and 15))]; 3238 Inc(HexValue,2); 3239 end; 3240end; 3241 3242procedure BinToHex(const BinBuffer: TBytes; BinBufOffset: Integer; var HexBuffer: TBytes; HexBufOffset: Integer; Count: Integer); 3243const 3244 HexDigits : String='0123456789ABCDEF'; 3245var 3246 i : longint; 3247begin 3248 for i:=0 to Count-1 do 3249 begin 3250 HexBuffer[HexBufOffset+2*i+0]:=Byte(HexDigits[1+(BinBuffer[BinBufOffset + i] shr 4)]); 3251 HexBuffer[HexBufOffset+2*i+1]:=Byte(HexDigits[1+(BinBuffer[BinBufOffset + i] and 15)]); 3252 end; 3253end; 3254 3255procedure BinToHex(BinValue: Pointer; HexValue: PAnsiChar; BinBufSize: Integer); 3256begin 3257 BinToHex(PAnsiChar(BinValue), HexValue, BinBufSize); 3258end; 3259 3260procedure BinToHex(BinValue: Pointer; HexValue: PWideChar; BinBufSize: Integer); 3261begin 3262 BinToHex(PAnsiChar(BinValue), HexValue, BinBufSize); 3263end; 3264 3265procedure BinToHex(const BinValue; HexValue: PAnsiChar; BinBufSize: Integer); 3266begin 3267 BinToHex(PAnsiChar(BinValue), HexValue, BinBufSize); 3268 end; 3269 3270procedure BinToHex(const BinValue; HexValue: PWideChar; BinBufSize: Integer); 3271begin 3272 BinToHex(PAnsiChar(BinValue), HexValue, BinBufSize); 3273end; 3274 3275 3276function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer; 3277// more complex, have to accept more than bintohex 3278// A..F 1000001 3279// a..f 1100001 3280// 0..9 110000 3281 3282var i,j,h,l : integer; 3283 3284begin 3285 i:=binbufsize; 3286 while (i>0) do 3287 begin 3288 if hexvalue^ IN ['A'..'F','a'..'f'] then 3289 h:=((ord(hexvalue^)+9) and 15) 3290 else if hexvalue^ IN ['0'..'9'] then 3291 h:=((ord(hexvalue^)) and 15) 3292 else 3293 break; 3294 inc(hexvalue); 3295 if hexvalue^ IN ['A'..'F','a'..'f'] then 3296 l:=(ord(hexvalue^)+9) and 15 3297 else if hexvalue^ IN ['0'..'9'] then 3298 l:=(ord(hexvalue^)) and 15 3299 else 3300 break; 3301 j := l + (h shl 4); 3302 inc(hexvalue); 3303 binvalue^:=chr(j); 3304 inc(binvalue); 3305 dec(i); 3306 end; 3307 result:=binbufsize-i; 3308end; 3309 3310function PosSetEx(const c: TSysCharSet; const s: ansistring; count: Integer): SizeInt; 3311 3312var i,j:SizeInt; 3313 3314begin 3315 if pchar(pointer(s))=nil then 3316 j:=0 3317 else 3318 begin 3319 i:=length(s); 3320 j:=count; 3321 if j>i then 3322 begin 3323 result:=0; 3324 exit; 3325 end; 3326 while (j<=i) and (not (s[j] in c)) do inc(j); 3327 if (j>i) then 3328 j:=0; // not found. 3329 end; 3330 result:=j; 3331end; 3332 3333function PosSet(const c: TSysCharSet; const s: ansistring): SizeInt; 3334 3335begin 3336 result:=possetex(c,s,1); 3337end; 3338 3339function PosSetEx(const c: string; const s: ansistring; count: Integer): SizeInt; 3340 3341var cset : TSysCharSet; 3342 i : SizeInt; 3343begin 3344 cset:=[]; 3345 if length(c)>0 then 3346 for i:=1 to length(c) do 3347 include(cset,c[i]); 3348 result:=possetex(cset,s,count); 3349end; 3350 3351function PosSet(const c: string; const s: ansistring): SizeInt; 3352 3353var cset : TSysCharSet; 3354 i : SizeInt; 3355begin 3356 cset:=[]; 3357 if length(c)>0 then 3358 for i:=1 to length(c) do 3359 include(cset,c[i]); 3360 result:=possetex(cset,s,1); 3361end; 3362 3363 3364procedure Removeleadingchars(VAR S: AnsiString; const CSet: TSysCharset); 3365 3366VAR I,J : Longint; 3367 3368Begin 3369 I:=Length(S); 3370 IF (I>0) Then 3371 Begin 3372 J:=1; 3373 While (J<=I) And (S[J] IN CSet) DO 3374 INC(J); 3375 IF J>1 Then 3376 Delete(S,1,J-1); 3377 End; 3378End; 3379 3380 3381function TrimLeftSet(const S: String;const CSet:TSysCharSet): String; 3382 3383begin 3384 result:=s; 3385 removeleadingchars(result,cset); 3386end; 3387 3388procedure RemoveTrailingChars(VAR S: AnsiString; const CSet: TSysCharset); 3389 3390VAR I,J: LONGINT; 3391 3392Begin 3393 I:=Length(S); 3394 IF (I>0) Then 3395 Begin 3396 J:=I; 3397 While (j>0) and (S[J] IN CSet) DO DEC(J); 3398 IF J<>I Then 3399 SetLength(S,J); 3400 End; 3401End; 3402 3403function TrimRightSet(const S: String; const CSet: TSysCharSet): String; 3404 3405begin 3406 result:=s; 3407 RemoveTrailingchars(result,cset); 3408end; 3409 3410procedure RemovePadChars(VAR S: AnsiString; const CSet: TSysCharset); 3411 3412VAR I,J,K: LONGINT; 3413 3414Begin 3415 I:=Length(S); 3416 IF (I>0) Then 3417 Begin 3418 J:=I; 3419 While (j>0) and (S[J] IN CSet) DO DEC(J); 3420 if j=0 Then 3421 begin 3422 s:=''; 3423 exit; 3424 end; 3425 k:=1; 3426 While (k<=I) And (S[k] IN CSet) DO 3427 INC(k); 3428 IF k>1 Then 3429 begin 3430 move(s[k],s[1],j-k+1); 3431 setlength(s,j-k+1); 3432 end 3433 else 3434 setlength(s,j); 3435 End; 3436End; 3437 3438function TrimSet(const S: String;const CSet:TSysCharSet): String; 3439 3440begin 3441 result:=s; 3442 RemovePadChars(result,cset); 3443end; 3444 3445 3446Function SplitCommandLine(S : RawByteString) : TRawByteStringArray; 3447 3448 Function GetNextWord : RawByteString; 3449 3450 Const 3451 WhiteSpace = [' ',#9,#10,#13]; 3452 Literals = ['"','''']; 3453 3454 Var 3455 Wstart,wend : Integer; 3456 InLiteral : Boolean; 3457 LastLiteral : AnsiChar; 3458 3459 Procedure AppendToResult; 3460 3461 begin 3462 Result:=Result+Copy(S,WStart,WEnd-WStart); 3463 WStart:=Wend+1; 3464 end; 3465 3466 begin 3467 Result:=''; 3468 WStart:=1; 3469 While (WStart<=Length(S)) and charinset(S[WStart],WhiteSpace) do 3470 Inc(WStart); 3471 WEnd:=WStart; 3472 InLiteral:=False; 3473 LastLiteral:=#0; 3474 While (Wend<=Length(S)) and (Not charinset(S[Wend],WhiteSpace) or InLiteral) do 3475 begin 3476 if charinset(S[Wend],Literals) then 3477 If InLiteral then 3478 begin 3479 InLiteral:=Not (S[Wend]=LastLiteral); 3480 if not InLiteral then 3481 AppendToResult; 3482 end 3483 else 3484 begin 3485 InLiteral:=True; 3486 LastLiteral:=S[Wend]; 3487 AppendToResult; 3488 end; 3489 inc(wend); 3490 end; 3491 AppendToResult; 3492 While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do 3493 inc(Wend); 3494 Delete(S,1,WEnd-1); 3495 end; 3496 3497Var 3498 W : RawByteString; 3499 len : Integer; 3500 3501begin 3502 Len:=0; 3503 Result:=Default(TRawByteStringArray); 3504 SetLength(Result,(Length(S) div 2)+1); 3505 While Length(S)>0 do 3506 begin 3507 W:=GetNextWord; 3508 If (W<>'') then 3509 begin 3510 Result[Len]:=W; 3511 Inc(Len); 3512 end; 3513 end; 3514 SetLength(Result,Len); 3515end; 3516 3517 3518Function SplitCommandLine(S : UnicodeString) : TUnicodeStringArray; 3519 3520 Function GetNextWord : UnicodeString; 3521 3522 Const 3523 WhiteSpace = [' ',#9,#10,#13]; 3524 Literals = ['"','''']; 3525 3526 Var 3527 Wstart,wend : Integer; 3528 InLiteral : Boolean; 3529 LastLiteral : AnsiChar; 3530 3531 Procedure AppendToResult; 3532 3533 begin 3534 Result:=Result+Copy(S,WStart,WEnd-WStart); 3535 WStart:=Wend+1; 3536 end; 3537 3538 begin 3539 Result:=''; 3540 WStart:=1; 3541 While (WStart<=Length(S)) and charinset(S[WStart],WhiteSpace) do 3542 Inc(WStart); 3543 WEnd:=WStart; 3544 InLiteral:=False; 3545 LastLiteral:=#0; 3546 While (Wend<=Length(S)) and (Not charinset(S[Wend],WhiteSpace) or InLiteral) do 3547 begin 3548 if charinset(S[Wend],Literals) then 3549 If InLiteral then 3550 begin 3551 InLiteral:=Not (S[Wend]=LastLiteral); 3552 if not InLiteral then 3553 AppendToResult; 3554 end 3555 else 3556 begin 3557 InLiteral:=True; 3558 LastLiteral:=S[Wend]; 3559 AppendToResult; 3560 end; 3561 inc(wend); 3562 end; 3563 AppendToResult; 3564 While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do 3565 inc(Wend); 3566 Delete(S,1,WEnd-1); 3567 end; 3568 3569Var 3570 W : UnicodeString; 3571 len : Integer; 3572 3573begin 3574 Len:=0; 3575 Result:=Default(TUnicodeStringArray); 3576 SetLength(Result,(Length(S) div 2)+1); 3577 While Length(S)>0 do 3578 begin 3579 W:=GetNextWord; 3580 If (W<>'') then 3581 begin 3582 Result[Len]:=W; 3583 Inc(Len); 3584 end; 3585 end; 3586 SetLength(Result,Len); 3587end; 3588 3589 3590end. 3591