strutils.pp 85 KB

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