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