strutils.pp 47 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908
  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;inline;
  24. Function AnsiEndsText(const ASubText, AText: string): Boolean;inline;
  25. Function AnsiReplaceText(const AText, AFromText, AToText: string): string;inline;
  26. Function AnsiMatchText(const AText: string; const AValues: array of string): Boolean;
  27. Function AnsiIndexText(const AText: string; const AValues: array of string): Integer;
  28. { ---------------------------------------------------------------------
  29. Case sensitive search/replace
  30. ---------------------------------------------------------------------}
  31. Function AnsiContainsStr(const AText, ASubText: string): Boolean;inline;
  32. Function AnsiStartsStr(const ASubText, AText: string): Boolean;inline;
  33. Function AnsiEndsStr(const ASubText, AText: string): Boolean;inline;
  34. Function AnsiReplaceStr(const AText, AFromText, AToText: string): string;inline;
  35. Function AnsiMatchStr(const AText: string; const AValues: array of string): Boolean;
  36. Function AnsiIndexStr(const AText: string; const AValues: array of string): Integer;
  37. { ---------------------------------------------------------------------
  38. Miscellaneous
  39. ---------------------------------------------------------------------}
  40. Function DupeString(const AText: string; ACount: Integer): string;
  41. Function ReverseString(const AText: string): string;
  42. Function AnsiReverseString(const AText: AnsiString): AnsiString;inline;
  43. Function StuffString(const AText: string; AStart, ALength: Cardinal; const ASubText: string): string;
  44. Function RandomFrom(const AValues: array of string): string; overload;
  45. Function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string = ''): string; overload;
  46. { ---------------------------------------------------------------------
  47. VB emulations.
  48. ---------------------------------------------------------------------}
  49. Function LeftStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  50. Function RightStr(const AText: AnsiString; const ACount: Integer): AnsiString;
  51. Function MidStr(const AText: AnsiString; const AStart, ACount: Integer): AnsiString;inline;
  52. Function RightBStr(const AText: AnsiString; const AByteCount: Integer): AnsiString;inline;
  53. Function MidBStr(const AText: AnsiString; const AByteStart, AByteCount: Integer): AnsiString;inline;
  54. Function AnsiLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  55. Function AnsiRightStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  56. Function AnsiMidStr(const AText: AnsiString; const AStart, ACount: Integer): AnsiString;inline;
  57. Function LeftBStr(const AText: AnsiString; const AByteCount: Integer): AnsiString;inline;
  58. Function LeftStr(const AText: WideString; const ACount: Integer): WideString;inline;
  59. Function RightStr(const AText: WideString; const ACount: Integer): WideString;
  60. Function MidStr(const AText: WideString; const AStart, ACount: Integer): WideString;inline;
  61. { ---------------------------------------------------------------------
  62. Extended search and replace
  63. ---------------------------------------------------------------------}
  64. const
  65. { Default word delimiters are any character except the core alphanumerics. }
  66. WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0'];
  67. resourcestring
  68. SErrAmountStrings = 'Amount of search and replace strings don''t match';
  69. type
  70. TStringSearchOption = (soDown, soMatchCase, soWholeWord);
  71. TStringSearchOptions = set of TStringSearchOption;
  72. TStringSeachOption = TStringSearchOption;
  73. Function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String; Options: TStringSearchOptions): PChar;
  74. Function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String): PChar;inline; // ; Options: TStringSearchOptions = [soDown]
  75. Function PosEx(const SubStr, S: string; Offset: Cardinal): Integer;
  76. Function PosEx(const SubStr, S: string): Integer;inline; // Offset: Cardinal = 1
  77. Function PosEx(c:char; const S: string; Offset: Cardinal): Integer;
  78. function StringsReplace(const S: string; OldPattern, NewPattern: array of string; Flags: TReplaceFlags): string;
  79. { ---------------------------------------------------------------------
  80. Soundex Functions.
  81. ---------------------------------------------------------------------}
  82. type
  83. TSoundexLength = 1..MaxInt;
  84. Function Soundex(const AText: string; ALength: TSoundexLength): string;
  85. Function Soundex(const AText: string): string;inline; // ; ALength: TSoundexLength = 4
  86. type
  87. TSoundexIntLength = 1..8;
  88. Function SoundexInt(const AText: string; ALength: TSoundexIntLength): Integer;
  89. Function SoundexInt(const AText: string): Integer;inline; //; ALength: TSoundexIntLength = 4
  90. Function DecodeSoundexInt(AValue: Integer): string;
  91. Function SoundexWord(const AText: string): Word;
  92. Function DecodeSoundexWord(AValue: Word): string;
  93. Function SoundexSimilar(const AText, AOther: string; ALength: TSoundexLength): Boolean;inline;
  94. Function SoundexSimilar(const AText, AOther: string): Boolean;inline; //; ALength: TSoundexLength = 4
  95. Function SoundexCompare(const AText, AOther: string; ALength: TSoundexLength): Integer;inline;
  96. Function SoundexCompare(const AText, AOther: string): Integer;inline; //; ALength: TSoundexLength = 4
  97. Function SoundexProc(const AText, AOther: string): Boolean;
  98. type
  99. TCompareTextProc = Function(const AText, AOther: string): Boolean;
  100. Const
  101. AnsiResemblesProc: TCompareTextProc = @SoundexProc;
  102. { ---------------------------------------------------------------------
  103. Other functions, based on RxStrUtils.
  104. ---------------------------------------------------------------------}
  105. function IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean;
  106. function DelSpace(const S: string): string;
  107. function DelChars(const S: string; Chr: Char): string;
  108. function DelSpace1(const S: string): string;
  109. function Tab2Space(const S: string; Numb: Byte): string;
  110. function NPos(const C: string; S: string; N: Integer): Integer;
  111. Function RPosEX(C:char;const S : AnsiString;offs:cardinal):Integer; overload;
  112. Function RPosex (Const Substr : AnsiString; Const Source : AnsiString;offs:cardinal) : Integer; overload;
  113. Function RPos(c:char;const S : AnsiString):Integer; overload;
  114. Function RPos (Const Substr : AnsiString; Const Source : AnsiString) : Integer; overload;
  115. function AddChar(C: Char; const S: string; N: Integer): string;
  116. function AddCharR(C: Char; const S: string; N: Integer): string;
  117. function PadLeft(const S: string; N: Integer): string;inline;
  118. function PadRight(const S: string; N: Integer): string;inline;
  119. function PadCenter(const S: string; Len: Integer): string;
  120. function Copy2Symb(const S: string; Symb: Char): string;
  121. function Copy2SymbDel(var S: string; Symb: Char): string;
  122. function Copy2Space(const S: string): string;inline;
  123. function Copy2SpaceDel(var S: string): string;inline;
  124. function AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string;
  125. function WordCount(const S: string; const WordDelims: TSysCharSet): Integer;
  126. function WordPosition(const N: Integer; const S: string; const WordDelims: TSysCharSet): Integer;
  127. function ExtractWord(N: Integer; const S: string; const WordDelims: TSysCharSet): string;inline;
  128. function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; var Pos: Integer): string;
  129. function ExtractDelimited(N: Integer; const S: string; const Delims: TSysCharSet): string;
  130. function ExtractSubstr(const S: string; var Pos: Integer; const Delims: TSysCharSet): string;
  131. function IsWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean;
  132. function FindPart(const HelpWilds, InputStr: string): Integer;
  133. function IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean;
  134. function XorString(const Key, Src: ShortString): ShortString;
  135. function XorEncode(const Key, Source: string): string;
  136. function XorDecode(const Key, Source: string): string;
  137. function GetCmdLineArg(const Switch: string; SwitchChars: TSysCharSet): string;
  138. function Numb2USA(const S: string): string;
  139. function Hex2Dec(const S: string): Longint;
  140. function Dec2Numb(N: Longint; Len, Base: Byte): string;
  141. function Numb2Dec(S: string; Base: Byte): Longint;
  142. function IntToBin(Value: Longint; Digits, Spaces: Integer): string;
  143. function IntToBin(Value: Longint; Digits: Integer): string;
  144. function intToBin(Value: int64; Digits:integer): string;
  145. function IntToRoman(Value: Longint): string;
  146. function RomanToInt(const S: string): Longint;
  147. procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer);
  148. function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer;
  149. const
  150. DigitChars = ['0'..'9'];
  151. Brackets = ['(',')','[',']','{','}'];
  152. StdWordDelims = [#0..' ',',','.',';','/','\',':','''','"','`'] + Brackets;
  153. StdSwitchChars = ['-','/'];
  154. function PosSet (const c:TSysCharSet;const s : ansistring ):Integer;
  155. function PosSet (const c:string;const s : ansistring ):Integer;
  156. function PosSetEx (const c:TSysCharSet;const s : ansistring;count:Integer ):Integer;
  157. function PosSetEx (const c:string;const s : ansistring;count:Integer ):Integer;
  158. Procedure Removeleadingchars(VAR S : AnsiString; Const CSet:TSysCharset);
  159. Procedure RemoveTrailingChars(VAR S : AnsiString;Const CSet:TSysCharset);
  160. Procedure RemovePadChars(VAR S : AnsiString;Const CSet:TSysCharset);
  161. function TrimLeftSet(const S: String;const CSet:TSysCharSet): String;
  162. Function TrimRightSet(const S: String;const CSet:TSysCharSet): String;
  163. function TrimSet(const S: String;const CSet:TSysCharSet): String;
  164. implementation
  165. { ---------------------------------------------------------------------
  166. Possibly Exception raising functions
  167. ---------------------------------------------------------------------}
  168. function Hex2Dec(const S: string): Longint;
  169. var
  170. HexStr: string;
  171. begin
  172. if Pos('$',S)=0 then
  173. HexStr:='$'+ S
  174. else
  175. HexStr:=S;
  176. Result:=StrToInt(HexStr);
  177. end;
  178. {
  179. We turn off implicit exceptions, since these routines are tested, and it
  180. saves 20% codesize (and some speed) and don't throw exceptions, except maybe
  181. heap related. If they don't, that is consider a bug.
  182. In the future, be wary with routines that use strtoint, floating point
  183. and/or format() derivatives. And check every divisor for 0.
  184. }
  185. {$IMPLICITEXCEPTIONS OFF}
  186. { ---------------------------------------------------------------------
  187. Case insensitive search/replace
  188. ---------------------------------------------------------------------}
  189. Function AnsiResemblesText(const AText, AOther: string): Boolean;
  190. begin
  191. if Assigned(AnsiResemblesProc) then
  192. Result:=AnsiResemblesProc(AText,AOther)
  193. else
  194. Result:=False;
  195. end;
  196. Function AnsiContainsText(const AText, ASubText: string): Boolean;
  197. begin
  198. AnsiContainsText:=AnsiPos(AnsiUppercase(ASubText),AnsiUppercase(AText))>0;
  199. end;
  200. Function AnsiStartsText(const ASubText, AText: string): Boolean;inline;
  201. begin
  202. Result:=AnsiCompareText(Copy(AText,1,Length(AsubText)),ASubText)=0;
  203. end;
  204. Function AnsiEndsText(const ASubText, AText: string): Boolean;inline;
  205. begin
  206. result:=AnsiCompareText(Copy(AText,Length(AText)-Length(ASubText)+1,Length(ASubText)),asubtext)=0;
  207. end;
  208. Function AnsiReplaceText(const AText, AFromText, AToText: string): string;inline;
  209. begin
  210. Result := StringReplace(AText,AFromText,AToText,[rfReplaceAll,rfIgnoreCase]);
  211. end;
  212. Function AnsiMatchText(const AText: string; const AValues: array of string): Boolean;
  213. begin
  214. Result:=(AnsiIndexText(AText,AValues)<>-1)
  215. end;
  216. Function AnsiIndexText(const AText: string; const AValues: array of string): Integer;
  217. var i : longint;
  218. begin
  219. result:=-1;
  220. if high(AValues)=-1 Then
  221. Exit;
  222. for i:=low(AValues) to High(Avalues) do
  223. if CompareText(avalues[i],atext)=0 Then
  224. exit(i); // make sure it is the first val.
  225. end;
  226. { ---------------------------------------------------------------------
  227. Case sensitive search/replace
  228. ---------------------------------------------------------------------}
  229. Function AnsiContainsStr(const AText, ASubText: string): Boolean;inline;
  230. begin
  231. Result := AnsiPos(ASubText,AText)>0;
  232. end;
  233. Function AnsiStartsStr(const ASubText, AText: string): Boolean;inline;
  234. begin
  235. Result := AnsiPos(ASubText,AText)=1;
  236. end;
  237. Function AnsiEndsStr(const ASubText, AText: string): Boolean;inline;
  238. begin
  239. Result := AnsiCompareStr(Copy(AText,length(AText)-length(ASubText)+1,length(ASubText)),ASubText)=0;
  240. end;
  241. Function AnsiReplaceStr(const AText, AFromText, AToText: string): string;inline;
  242. begin
  243. Result := StringReplace(AText,AFromText,AToText,[rfReplaceAll]);
  244. end;
  245. Function AnsiMatchStr(const AText: string; const AValues: array of string): Boolean;
  246. begin
  247. Result:=AnsiIndexStr(AText,Avalues)<>-1;
  248. end;
  249. Function AnsiIndexStr(const AText: string; const AValues: array of string): Integer;
  250. var
  251. i : longint;
  252. begin
  253. result:=-1;
  254. if high(AValues)=-1 Then
  255. Exit;
  256. for i:=low(AValues) to High(Avalues) do
  257. if (avalues[i]=AText) Then
  258. exit(i); // make sure it is the first val.
  259. end;
  260. { ---------------------------------------------------------------------
  261. Playthingies
  262. ---------------------------------------------------------------------}
  263. Function DupeString(const AText: string; ACount: Integer): string;
  264. var i,l : integer;
  265. begin
  266. result:='';
  267. if aCount>=0 then
  268. begin
  269. l:=length(atext);
  270. SetLength(result,aCount*l);
  271. for i:=0 to ACount-1 do
  272. move(atext[1],Result[l*i+1],l);
  273. end;
  274. end;
  275. Function ReverseString(const AText: string): string;
  276. var
  277. i,j:longint;
  278. begin
  279. setlength(result,length(atext));
  280. i:=1; j:=length(atext);
  281. while (i<=j) do
  282. begin
  283. result[i]:=atext[j-i+1];
  284. inc(i);
  285. end;
  286. end;
  287. Function AnsiReverseString(const AText: AnsiString): AnsiString;inline;
  288. begin
  289. Result:=ReverseString(AText);
  290. end;
  291. Function StuffString(const AText: string; AStart, ALength: Cardinal; const ASubText: string): string;
  292. var i,j,k : SizeUInt;
  293. begin
  294. j:=length(ASubText);
  295. i:=length(AText);
  296. if AStart>i then
  297. aStart:=i+1;
  298. k:=i+1-AStart;
  299. if ALength> k then
  300. ALength:=k;
  301. SetLength(Result,i+j-ALength);
  302. move (AText[1],result[1],AStart-1);
  303. move (ASubText[1],result[AStart],j);
  304. move (AText[AStart+ALength], Result[AStart+j],i+1-AStart-ALength);
  305. end;
  306. Function RandomFrom(const AValues: array of string): string; overload;
  307. begin
  308. if high(AValues)=-1 then exit('');
  309. result:=Avalues[random(High(AValues)+1)];
  310. end;
  311. Function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string = ''): string; overload;
  312. begin
  313. if avalue then
  314. result:=atrue
  315. else
  316. result:=afalse;
  317. end;
  318. { ---------------------------------------------------------------------
  319. VB emulations.
  320. ---------------------------------------------------------------------}
  321. Function LeftStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  322. begin
  323. Result:=Copy(AText,1,ACount);
  324. end;
  325. Function RightStr(const AText: AnsiString; const ACount: Integer): AnsiString;
  326. var j,l:integer;
  327. begin
  328. l:=length(atext);
  329. j:=ACount;
  330. if j>l then j:=l;
  331. Result:=Copy(AText,l-j+1,j);
  332. end;
  333. Function MidStr(const AText: AnsiString; const AStart, ACount: Integer): AnsiString;inline;
  334. begin
  335. if (ACount=0) or (AStart>length(atext)) then
  336. exit('');
  337. Result:=Copy(AText,AStart,ACount);
  338. end;
  339. Function LeftBStr(const AText: AnsiString; const AByteCount: Integer): AnsiString;inline;
  340. begin
  341. Result:=LeftStr(AText,AByteCount);
  342. end;
  343. Function RightBStr(const AText: AnsiString; const AByteCount: Integer): AnsiString;inline;
  344. begin
  345. Result:=RightStr(Atext,AByteCount);
  346. end;
  347. Function MidBStr(const AText: AnsiString; const AByteStart, AByteCount: Integer): AnsiString;inline;
  348. begin
  349. Result:=MidStr(AText,AByteStart,AByteCount);
  350. end;
  351. Function AnsiLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  352. begin
  353. Result := copy(AText,1,ACount);
  354. end;
  355. Function AnsiRightStr(const AText: AnsiString; const ACount: Integer): AnsiString;inline;
  356. begin
  357. Result := copy(AText,length(AText)-ACount+1,ACount);
  358. end;
  359. Function AnsiMidStr(const AText: AnsiString; const AStart, ACount: Integer): AnsiString;inline;
  360. begin
  361. Result:=Copy(AText,AStart,ACount);
  362. end;
  363. Function LeftStr(const AText: WideString; const ACount: Integer): WideString;inline;
  364. begin
  365. Result:=Copy(AText,1,ACount);
  366. end;
  367. Function RightStr(const AText: WideString; const ACount: Integer): WideString;
  368. var
  369. j,l:integer;
  370. begin
  371. l:=length(atext);
  372. j:=ACount;
  373. if j>l then j:=l;
  374. Result:=Copy(AText,l-j+1,j);
  375. end;
  376. Function MidStr(const AText: WideString; const AStart, ACount: Integer): WideString;inline;
  377. begin
  378. Result:=Copy(AText,AStart,ACount);
  379. end;
  380. { ---------------------------------------------------------------------
  381. Extended search and replace
  382. ---------------------------------------------------------------------}
  383. type
  384. TEqualFunction = function (const a,b : char) : boolean;
  385. function EqualWithCase (const a,b : char) : boolean;
  386. begin
  387. result := (a = b);
  388. end;
  389. function EqualWithoutCase (const a,b : char) : boolean;
  390. begin
  391. result := (lowerCase(a) = lowerCase(b));
  392. end;
  393. function IsWholeWord (bufstart, bufend, wordstart, wordend : pchar) : boolean;
  394. begin
  395. // Check start
  396. result := ((wordstart = bufstart) or ((wordstart-1)^ in worddelimiters)) and
  397. // Check end
  398. ((wordend = bufend) or ((wordend+1)^ in worddelimiters));
  399. end;
  400. function SearchDown(buf,aStart,endchar:pchar; SearchString:string;
  401. Equals : TEqualFunction; WholeWords:boolean) : pchar;
  402. var Found : boolean;
  403. s, c : pchar;
  404. begin
  405. result := aStart;
  406. Found := false;
  407. while not Found and (result <= endchar) do
  408. begin
  409. // Search first letter
  410. while (result <= endchar) and not Equals(result^,SearchString[1]) do
  411. inc (result);
  412. // Check if following is searchstring
  413. c := result;
  414. s := @(Searchstring[1]);
  415. Found := true;
  416. while (c <= endchar) and (s^ <> #0) and Found do
  417. begin
  418. Found := Equals(c^, s^);
  419. inc (c);
  420. inc (s);
  421. end;
  422. if s^ <> #0 then
  423. Found := false;
  424. // Check if it is a word
  425. if Found and WholeWords then
  426. Found := IsWholeWord(buf,endchar,result,c-1);
  427. if not found then
  428. inc (result);
  429. end;
  430. if not Found then
  431. result := nil;
  432. end;
  433. function SearchUp(buf,aStart,endchar:pchar; SearchString:string;
  434. equals : TEqualFunction; WholeWords:boolean) : pchar;
  435. var Found : boolean;
  436. s, c, l : pchar;
  437. begin
  438. result := aStart;
  439. Found := false;
  440. l := @(SearchString[length(SearchString)]);
  441. while not Found and (result >= buf) do
  442. begin
  443. // Search last letter
  444. while (result >= buf) and not Equals(result^,l^) do
  445. dec (result);
  446. // Check if before is searchstring
  447. c := result;
  448. s := l;
  449. Found := true;
  450. while (c >= buf) and (s >= @SearchString[1]) and Found do
  451. begin
  452. Found := Equals(c^, s^);
  453. dec (c);
  454. dec (s);
  455. end;
  456. if (s >= @(SearchString[1])) then
  457. Found := false;
  458. // Check if it is a word
  459. if Found and WholeWords then
  460. Found := IsWholeWord(buf,endchar,c+1,result);
  461. if found then
  462. result := c+1
  463. else
  464. dec (result);
  465. end;
  466. if not Found then
  467. result := nil;
  468. end;
  469. //function SearchDown(buf,aStart,endchar:pchar; SearchString:string; equal : TEqualFunction; WholeWords:boolean) : pchar;
  470. function SearchBuf(Buf: PChar;BufLen: Integer;SelStart: Integer;SelLength: Integer;
  471. SearchString: String;Options: TStringSearchOptions):PChar;
  472. var
  473. equal : TEqualFunction;
  474. begin
  475. SelStart := SelStart + SelLength;
  476. if (SearchString = '') or (SelStart > BufLen) or (SelStart < 0) then
  477. result := nil
  478. else
  479. begin
  480. if soMatchCase in Options then
  481. Equal := @EqualWithCase
  482. else
  483. Equal := @EqualWithoutCase;
  484. if soDown in Options then
  485. result := SearchDown(buf,buf+SelStart,Buf+(BufLen-1), SearchString, Equal, (soWholeWord in Options))
  486. else
  487. result := SearchUp(buf,buf+SelStart,Buf+(Buflen-1), SearchString, Equal, (soWholeWord in Options));
  488. end;
  489. end;
  490. Function SearchBuf(Buf: PChar; BufLen: Integer; SelStart, SelLength: Integer; SearchString: String): PChar;inline; // ; Options: TStringSearchOptions = [soDown]
  491. begin
  492. Result:=SearchBuf(Buf,BufLen,SelStart,SelLength,SearchString,[soDown]);
  493. end;
  494. Function PosEx(const SubStr, S: string; Offset: Cardinal): Integer;
  495. var i : pchar;
  496. begin
  497. if (offset<1) or (offset>SizeUInt(length(s))) then exit(0);
  498. i:=strpos(@s[offset],@substr[1]);
  499. if i=nil then
  500. PosEx:=0
  501. else
  502. PosEx:=succ(i-pchar(pointer(s)));
  503. end;
  504. Function PosEx(const SubStr, S: string): Integer;inline; // Offset: Cardinal = 1
  505. begin
  506. posex:=posex(substr,s,1);
  507. end;
  508. Function PosEx(c:char; const S: string; Offset: Cardinal): Integer;
  509. var l : longint;
  510. begin
  511. if (offset<1) or (offset>SizeUInt(length(s))) then exit(0);
  512. l:=length(s);
  513. {$ifndef useindexbyte}
  514. while (SizeInt(offset)<=l) and (s[offset]<>c) do inc(offset);
  515. if SizeInt(offset)>l then
  516. posex:=0
  517. else
  518. posex:=offset;
  519. {$else}
  520. posex:=offset+indexbyte(s[offset],l-offset+1);
  521. if posex=(offset-1) then
  522. posex:=0;
  523. {$endif}
  524. end;
  525. function StringsReplace(const S: string; OldPattern, NewPattern: array of string; Flags: TReplaceFlags): string;
  526. var pc,pcc,lastpc : pchar;
  527. strcount : integer;
  528. ResStr,
  529. CompStr : string;
  530. Found : Boolean;
  531. sc : integer;
  532. begin
  533. sc := length(OldPattern);
  534. if sc <> length(NewPattern) then
  535. raise exception.Create(SErrAmountStrings);
  536. dec(sc);
  537. if rfIgnoreCase in Flags then
  538. begin
  539. CompStr:=AnsiUpperCase(S);
  540. for strcount := 0 to sc do
  541. OldPattern[strcount] := AnsiUpperCase(OldPattern[strcount]);
  542. end
  543. else
  544. CompStr := s;
  545. ResStr := '';
  546. pc := @CompStr[1];
  547. pcc := @s[1];
  548. lastpc := pc+Length(S);
  549. while pc < lastpc do
  550. begin
  551. Found := False;
  552. for strcount := 0 to sc do
  553. begin
  554. if (length(OldPattern[strcount])>0) and
  555. (OldPattern[strcount][1]=pc^) and
  556. (Length(OldPattern[strcount]) <= (lastpc-pc)) and
  557. (CompareByte(OldPattern[strcount][1],pc^,Length(OldPattern[strcount]))=0) then
  558. begin
  559. ResStr := ResStr + NewPattern[strcount];
  560. pc := pc+Length(OldPattern[strcount]);
  561. pcc := pcc+Length(OldPattern[strcount]);
  562. Found := true;
  563. end
  564. end;
  565. if not found then
  566. begin
  567. ResStr := ResStr + pcc^;
  568. inc(pc);
  569. inc(pcc);
  570. end
  571. else if not (rfReplaceAll in Flags) then
  572. begin
  573. ResStr := ResStr + StrPas(pcc);
  574. break;
  575. end;
  576. end;
  577. Result := ResStr;
  578. end;
  579. { ---------------------------------------------------------------------
  580. Soundex Functions.
  581. ---------------------------------------------------------------------}
  582. Const
  583. SScore : array[1..255] of Char =
  584. ('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
  585. '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
  586. '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', // 64..90
  587. '0','0','0','0','0','0', // 91..95
  588. '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', // 96..122
  589. '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
  590. '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
  591. '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
  592. '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
  593. '0','0','0','0','0'); // 251..255
  594. Function Soundex(const AText: string; ALength: TSoundexLength): string;
  595. Var
  596. S,PS : Char;
  597. I,L : integer;
  598. begin
  599. Result:='';
  600. PS:=#0;
  601. If Length(AText)>0 then
  602. begin
  603. Result:=Upcase(AText[1]);
  604. I:=2;
  605. L:=Length(AText);
  606. While (I<=L) and (Length(Result)<ALength) do
  607. begin
  608. S:=SScore[Ord(AText[i])];
  609. If Not (S in ['0','i',PS]) then
  610. Result:=Result+S;
  611. If (S<>'i') then
  612. PS:=S;
  613. Inc(I);
  614. end;
  615. end;
  616. L:=Length(Result);
  617. If (L<ALength) then
  618. Result:=Result+StringOfChar('0',Alength-L);
  619. end;
  620. Function Soundex(const AText: string): string;inline; // ; ALength: TSoundexLength = 4
  621. begin
  622. Result:=Soundex(AText,4);
  623. end;
  624. Const
  625. Ord0 = Ord('0');
  626. OrdA = Ord('A');
  627. Function SoundexInt(const AText: string; ALength: TSoundexIntLength): Integer;
  628. var
  629. SE: string;
  630. I: Integer;
  631. begin
  632. Result:=-1;
  633. SE:=Soundex(AText,ALength);
  634. If Length(SE)>0 then
  635. begin
  636. Result:=Ord(SE[1])-OrdA;
  637. if ALength > 1 then
  638. begin
  639. Result:=Result*26+(Ord(SE[2])-Ord0);
  640. for I:=3 to ALength do
  641. Result:=(Ord(SE[I])-Ord0)+Result*7;
  642. end;
  643. Result:=ALength+Result*9;
  644. end;
  645. end;
  646. Function SoundexInt(const AText: string): Integer;inline; //; ALength: TSoundexIntLength = 4
  647. begin
  648. Result:=SoundexInt(AText,4);
  649. end;
  650. Function DecodeSoundexInt(AValue: Integer): string;
  651. var
  652. I, Len: Integer;
  653. begin
  654. Result := '';
  655. Len := AValue mod 9;
  656. AValue := AValue div 9;
  657. for I:=Len downto 3 do
  658. begin
  659. Result:=Chr(Ord0+(AValue mod 7))+Result;
  660. AValue:=AValue div 7;
  661. end;
  662. if Len>1 then
  663. begin
  664. Result:=Chr(Ord0+(AValue mod 26))+Result;
  665. AValue:=AValue div 26;
  666. end;
  667. Result:=Chr(OrdA+AValue)+Result;
  668. end;
  669. Function SoundexWord(const AText: string): Word;
  670. Var
  671. S : String;
  672. begin
  673. S:=SoundEx(Atext,4);
  674. Result:=Ord(S[1])-OrdA;
  675. Result:=Result*26+ord(S[2])-48;
  676. Result:=Result*7+ord(S[3])-48;
  677. Result:=Result*7+ord(S[4])-48;
  678. end;
  679. Function DecodeSoundexWord(AValue: Word): string;
  680. begin
  681. Result := Chr(Ord0+ (AValue mod 7));
  682. AValue := AValue div 7;
  683. Result := Chr(Ord0+ (AValue mod 7)) + Result;
  684. AValue := AValue div 7;
  685. Result := IntToStr(AValue mod 26) + Result;
  686. AValue := AValue div 26;
  687. Result := Chr(OrdA+AValue) + Result;
  688. end;
  689. Function SoundexSimilar(const AText, AOther: string; ALength: TSoundexLength): Boolean;inline;
  690. begin
  691. Result:=Soundex(AText,ALength)=Soundex(AOther,ALength);
  692. end;
  693. Function SoundexSimilar(const AText, AOther: string): Boolean;inline; //; ALength: TSoundexLength = 4
  694. begin
  695. Result:=SoundexSimilar(AText,AOther,4);
  696. end;
  697. Function SoundexCompare(const AText, AOther: string; ALength: TSoundexLength): Integer;inline;
  698. begin
  699. Result:=AnsiCompareStr(Soundex(AText,ALength),Soundex(AOther,ALength));
  700. end;
  701. Function SoundexCompare(const AText, AOther: string): Integer;inline; //; ALength: TSoundexLength = 4
  702. begin
  703. Result:=SoundexCompare(AText,AOther,4);
  704. end;
  705. Function SoundexProc(const AText, AOther: string): Boolean;
  706. begin
  707. Result:=SoundexSimilar(AText,AOther);
  708. end;
  709. { ---------------------------------------------------------------------
  710. RxStrUtils-like functions.
  711. ---------------------------------------------------------------------}
  712. function IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean;
  713. var
  714. i,l: Integer;
  715. begin
  716. l:=Length(S);
  717. i:=1;
  718. Result:=True;
  719. while Result and (i<=l) do
  720. begin
  721. Result:=(S[i] in EmptyChars);
  722. Inc(i);
  723. end;
  724. end;
  725. function DelSpace(const S: String): string;
  726. begin
  727. Result:=DelChars(S,' ');
  728. end;
  729. function DelChars(const S: string; Chr: Char): string;
  730. var
  731. I,J: Integer;
  732. begin
  733. Result:=S;
  734. I:=Length(Result);
  735. While I>0 do
  736. begin
  737. if Result[I]=Chr then
  738. begin
  739. J:=I-1;
  740. While (J>0) and (Result[J]=Chr) do
  741. Dec(j);
  742. Delete(Result,J+1,I-J);
  743. I:=J+1;
  744. end;
  745. dec(I);
  746. end;
  747. end;
  748. function DelSpace1(const S: string): string;
  749. var
  750. i: Integer;
  751. begin
  752. Result:=S;
  753. for i:=Length(Result) downto 2 do
  754. if (Result[i]=' ') and (Result[I-1]=' ') then
  755. Delete(Result,I,1);
  756. end;
  757. function Tab2Space(const S: string; Numb: Byte): string;
  758. var
  759. I: Integer;
  760. begin
  761. I:=1;
  762. Result:=S;
  763. while I <= Length(Result) do
  764. if Result[I]<>Chr(9) then
  765. inc(I)
  766. else
  767. begin
  768. Result[I]:=' ';
  769. If (Numb>1) then
  770. Insert(StringOfChar(' ',Numb-1),Result,I);
  771. Inc(I,Numb);
  772. end;
  773. end;
  774. function NPos(const C: string; S: string; N: Integer): Integer;
  775. var
  776. i,p,k: Integer;
  777. begin
  778. Result:=0;
  779. if N<1 then
  780. Exit;
  781. k:=0;
  782. i:=1;
  783. Repeat
  784. p:=pos(C,S);
  785. Inc(k,p);
  786. if p>0 then
  787. delete(S,1,p);
  788. Inc(i);
  789. Until (i>n) or (p=0);
  790. If (P>0) then
  791. Result:=K;
  792. end;
  793. function AddChar(C: Char; const S: string; N: Integer): string;
  794. Var
  795. l : Integer;
  796. begin
  797. Result:=S;
  798. l:=Length(Result);
  799. if l<N then
  800. Result:=StringOfChar(C,N-l)+Result;
  801. end;
  802. function AddCharR(C: Char; const S: string; N: Integer): string;
  803. Var
  804. l : Integer;
  805. begin
  806. Result:=S;
  807. l:=Length(Result);
  808. if l<N then
  809. Result:=Result+StringOfChar(C,N-l);
  810. end;
  811. function PadRight(const S: string; N: Integer): string;inline;
  812. begin
  813. Result:=AddCharR(' ',S,N);
  814. end;
  815. function PadLeft(const S: string; N: Integer): string;inline;
  816. begin
  817. Result:=AddChar(' ',S,N);
  818. end;
  819. function Copy2Symb(const S: string; Symb: Char): string;
  820. var
  821. p: Integer;
  822. begin
  823. p:=Pos(Symb,S);
  824. if p=0 then
  825. p:=Length(S)+1;
  826. Result:=Copy(S,1,p-1);
  827. end;
  828. function Copy2SymbDel(var S: string; Symb: Char): string;
  829. var
  830. p: Integer;
  831. begin
  832. p:=Pos(Symb,S);
  833. if p=0 then
  834. begin
  835. result:=s;
  836. s:='';
  837. end
  838. else
  839. begin
  840. Result:=Copy(S,1,p-1);
  841. delete(s,1,p);
  842. end;
  843. end;
  844. function Copy2Space(const S: string): string;inline;
  845. begin
  846. Result:=Copy2Symb(S,' ');
  847. end;
  848. function Copy2SpaceDel(var S: string): string;inline;
  849. begin
  850. Result:=Copy2SymbDel(S,' ');
  851. end;
  852. function AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string;
  853. var
  854. // l : Integer;
  855. P,PE : PChar;
  856. begin
  857. Result:=AnsiLowerCase(S);
  858. P:=PChar(pointer(Result));
  859. PE:=P+Length(Result);
  860. while (P<PE) do
  861. begin
  862. while (P<PE) and (P^ in WordDelims) do
  863. inc(P);
  864. if (P<PE) then
  865. P^:=UpCase(P^);
  866. while (P<PE) and not (P^ in WordDelims) do
  867. inc(P);
  868. end;
  869. end;
  870. function WordCount(const S: string; const WordDelims: TSysCharSet): Integer;
  871. var
  872. P,PE : PChar;
  873. begin
  874. Result:=0;
  875. P:=Pchar(pointer(S));
  876. PE:=P+Length(S);
  877. while (P<PE) do
  878. begin
  879. while (P<PE) and (P^ in WordDelims) do
  880. Inc(P);
  881. if (P<PE) then
  882. inc(Result);
  883. while (P<PE) and not (P^ in WordDelims) do
  884. inc(P);
  885. end;
  886. end;
  887. function WordPosition(const N: Integer; const S: string; const WordDelims: TSysCharSet): Integer;
  888. var
  889. PS,P,PE : PChar;
  890. Count: Integer;
  891. begin
  892. Result:=0;
  893. Count:=0;
  894. PS:=PChar(pointer(S));
  895. PE:=PS+Length(S);
  896. P:=PS;
  897. while (P<PE) and (Count<>N) do
  898. begin
  899. while (P<PE) and (P^ in WordDelims) do
  900. inc(P);
  901. if (P<PE) then
  902. inc(Count);
  903. if (Count<>N) then
  904. while (P<PE) and not (P^ in WordDelims) do
  905. inc(P)
  906. else
  907. Result:=(P-PS)+1;
  908. end;
  909. end;
  910. function ExtractWord(N: Integer; const S: string; const WordDelims: TSysCharSet): string;inline;
  911. var
  912. i: Integer;
  913. begin
  914. Result:=ExtractWordPos(N,S,WordDelims,i);
  915. end;
  916. function ExtractWordPos(N: Integer; const S: string; const WordDelims: TSysCharSet; var Pos: Integer): string;
  917. var
  918. i,j,l: Integer;
  919. begin
  920. j:=0;
  921. i:=WordPosition(N, S, WordDelims);
  922. Pos:=i;
  923. if (i<>0) then
  924. begin
  925. j:=i;
  926. l:=Length(S);
  927. while (j<=L) and not (S[j] in WordDelims) do
  928. inc(j);
  929. end;
  930. SetLength(Result,j-i);
  931. If ((j-i)>0) then
  932. Move(S[i],Result[1],j-i);
  933. end;
  934. function ExtractDelimited(N: Integer; const S: string; const Delims: TSysCharSet): string;
  935. var
  936. w,i,l,len: Integer;
  937. begin
  938. w:=0;
  939. i:=1;
  940. l:=0;
  941. len:=Length(S);
  942. SetLength(Result, 0);
  943. while (i<=len) and (w<>N) do
  944. begin
  945. if s[i] in Delims then
  946. inc(w)
  947. else
  948. begin
  949. if (N-1)=w then
  950. begin
  951. inc(l);
  952. SetLength(Result,l);
  953. Result[L]:=S[i];
  954. end;
  955. end;
  956. inc(i);
  957. end;
  958. end;
  959. function ExtractSubstr(const S: string; var Pos: Integer; const Delims: TSysCharSet): string;
  960. var
  961. i,l: Integer;
  962. begin
  963. i:=Pos;
  964. l:=Length(S);
  965. while (i<=l) and not (S[i] in Delims) do
  966. inc(i);
  967. Result:=Copy(S,Pos,i-Pos);
  968. while (i<=l) and (S[i] in Delims) do
  969. inc(i);
  970. Pos:=i;
  971. end;
  972. function isWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean;
  973. var
  974. i,Count : Integer;
  975. begin
  976. Result:=False;
  977. Count:=WordCount(S, WordDelims);
  978. I:=1;
  979. While (Not Result) and (I<=Count) do
  980. begin
  981. Result:=ExtractWord(i,S,WordDelims)=W;
  982. Inc(i);
  983. end;
  984. end;
  985. function Numb2USA(const S: string): string;
  986. var
  987. i, NA: Integer;
  988. begin
  989. i:=Length(S);
  990. Result:=S;
  991. NA:=0;
  992. while (i > 0) do begin
  993. if ((Length(Result) - i + 1 - NA) mod 3 = 0) and (i <> 1) then
  994. begin
  995. insert(',', Result, i);
  996. inc(NA);
  997. end;
  998. Dec(i);
  999. end;
  1000. end;
  1001. function PadCenter(const S: string; Len: Integer): string;
  1002. begin
  1003. if Length(S)<Len then
  1004. begin
  1005. Result:=StringOfChar(' ',(Len div 2) -(Length(S) div 2))+S;
  1006. Result:=Result+StringOfChar(' ',Len-Length(Result));
  1007. end
  1008. else
  1009. Result:=S;
  1010. end;
  1011. function Dec2Numb(N: Longint; Len, Base: Byte): string;
  1012. var
  1013. C: Integer;
  1014. Number: Longint;
  1015. begin
  1016. if N=0 then
  1017. Result:='0'
  1018. else
  1019. begin
  1020. Number:=N;
  1021. Result:='';
  1022. while Number>0 do
  1023. begin
  1024. C:=Number mod Base;
  1025. if C>9 then
  1026. C:=C+55
  1027. else
  1028. C:=C+48;
  1029. Result:=Chr(C)+Result;
  1030. Number:=Number div Base;
  1031. end;
  1032. end;
  1033. if (Result<>'') then
  1034. Result:=AddChar('0',Result,Len);
  1035. end;
  1036. function Numb2Dec(S: string; Base: Byte): Longint;
  1037. var
  1038. i, P: Longint;
  1039. begin
  1040. i:=Length(S);
  1041. Result:=0;
  1042. S:=UpperCase(S);
  1043. P:=1;
  1044. while (i>=1) do
  1045. begin
  1046. if (S[i]>'@') then
  1047. Result:=Result+(Ord(S[i])-55)*P
  1048. else
  1049. Result:=Result+(Ord(S[i])-48)*P;
  1050. Dec(i);
  1051. P:=P*Base;
  1052. end;
  1053. end;
  1054. function RomanToint(const S: string): Longint;
  1055. const
  1056. RomanChars = ['C','D','I','L','M','V','X'];
  1057. RomanValues : array['C'..'X'] of Word
  1058. = (100,500,0,0,0,0,1,0,0,50,1000,0,0,0,0,0,0,0,0,5,0,10);
  1059. var
  1060. index, Next: Char;
  1061. i,l: Integer;
  1062. Negative: Boolean;
  1063. begin
  1064. Result:=0;
  1065. i:=0;
  1066. Negative:=(Length(S)>0) and (S[1]='-');
  1067. if Negative then
  1068. inc(i);
  1069. l:=Length(S);
  1070. while (i<l) do
  1071. begin
  1072. inc(i);
  1073. index:=UpCase(S[i]);
  1074. if index in RomanChars then
  1075. begin
  1076. if Succ(i)<=l then
  1077. Next:=UpCase(S[i+1])
  1078. else
  1079. Next:=#0;
  1080. if (Next in RomanChars) and (RomanValues[index]<RomanValues[Next]) then
  1081. begin
  1082. inc(Result, RomanValues[Next]);
  1083. Dec(Result, RomanValues[index]);
  1084. inc(i);
  1085. end
  1086. else
  1087. inc(Result, RomanValues[index]);
  1088. end
  1089. else
  1090. begin
  1091. Result:=0;
  1092. Exit;
  1093. end;
  1094. end;
  1095. if Negative then
  1096. Result:=-Result;
  1097. end;
  1098. function intToRoman(Value: Longint): string;
  1099. const
  1100. Arabics : Array[1..13] of Integer
  1101. = (1,4,5,9,10,40,50,90,100,400,500,900,1000);
  1102. Romans : Array[1..13] of String
  1103. = ('I','IV','V','IX','X','XL','L','XC','C','CD','D','CM','M');
  1104. var
  1105. i: Integer;
  1106. begin
  1107. Result:='';
  1108. for i:=13 downto 1 do
  1109. while (Value >= Arabics[i]) do
  1110. begin
  1111. Value:=Value-Arabics[i];
  1112. Result:=Result+Romans[i];
  1113. end;
  1114. end;
  1115. function intToBin(Value: Longint; Digits, Spaces: Integer): string;
  1116. var endpos : integer;
  1117. p,p2:pchar;
  1118. k: integer;
  1119. begin
  1120. Result:='';
  1121. if (Digits>32) then
  1122. Digits:=32;
  1123. if (spaces=0) then
  1124. begin
  1125. result:=inttobin(value,digits);
  1126. exit;
  1127. end;
  1128. endpos:=digits+ (digits-1) div spaces;
  1129. setlength(result,endpos);
  1130. p:=@result[endpos];
  1131. p2:=@result[1];
  1132. k:=spaces;
  1133. while (p>=p2) do
  1134. begin
  1135. if k=0 then
  1136. begin
  1137. p^:=' ';
  1138. dec(p);
  1139. k:=spaces;
  1140. end;
  1141. p^:=chr(48+(cardinal(value) and 1));
  1142. value:=cardinal(value) shr 1;
  1143. dec(p);
  1144. dec(k);
  1145. end;
  1146. end;
  1147. function intToBin(Value: Longint; Digits:integer): string;
  1148. var p,p2 : pchar;
  1149. begin
  1150. result:='';
  1151. if digits<=0 then exit;
  1152. setlength(result,digits);
  1153. p:=pchar(pointer(@result[digits]));
  1154. p2:=pchar(pointer(@result[1]));
  1155. // typecasts because we want to keep intto* delphi compat and take an integer
  1156. while (p>=p2) and (cardinal(value)>0) do
  1157. begin
  1158. p^:=chr(48+(cardinal(value) and 1));
  1159. value:=cardinal(value) shr 1;
  1160. dec(p);
  1161. end;
  1162. digits:=p-p2+1;
  1163. if digits>0 then
  1164. fillchar(result[1],digits,#48);
  1165. end;
  1166. function intToBin(Value: int64; Digits:integer): string;
  1167. var p,p2 : pchar;
  1168. begin
  1169. result:='';
  1170. if digits<=0 then exit;
  1171. setlength(result,digits);
  1172. p:=pchar(pointer(@result[digits]));
  1173. p2:=pchar(pointer(@result[1]));
  1174. // typecasts because we want to keep intto* delphi compat and take a signed val
  1175. // and avoid warnings
  1176. while (p>=p2) and (qword(value)>0) do
  1177. begin
  1178. p^:=chr(48+(cardinal(value) and 1));
  1179. value:=qword(value) shr 1;
  1180. dec(p);
  1181. end;
  1182. digits:=p-p2+1;
  1183. if digits>0 then
  1184. fillchar(result[1],digits,#48);
  1185. end;
  1186. function FindPart(const HelpWilds, inputStr: string): Integer;
  1187. var
  1188. i, J: Integer;
  1189. Diff: Integer;
  1190. begin
  1191. Result:=0;
  1192. i:=Pos('?',HelpWilds);
  1193. if (i=0) then
  1194. Result:=Pos(HelpWilds, inputStr)
  1195. else
  1196. begin
  1197. Diff:=Length(inputStr) - Length(HelpWilds);
  1198. for i:=0 to Diff do
  1199. begin
  1200. for J:=1 to Length(HelpWilds) do
  1201. if (inputStr[i + J] = HelpWilds[J]) or (HelpWilds[J] = '?') then
  1202. begin
  1203. if (J=Length(HelpWilds)) then
  1204. begin
  1205. Result:=i+1;
  1206. Exit;
  1207. end;
  1208. end
  1209. else
  1210. Break;
  1211. end;
  1212. end;
  1213. end;
  1214. function isWild(inputStr, Wilds: string; ignoreCase: Boolean): Boolean;
  1215. function SearchNext(var Wilds: string): Integer;
  1216. begin
  1217. Result:=Pos('*', Wilds);
  1218. if Result>0 then
  1219. Wilds:=Copy(Wilds,1,Result - 1);
  1220. end;
  1221. var
  1222. CWild, CinputWord: Integer; { counter for positions }
  1223. i, LenHelpWilds: Integer;
  1224. MaxinputWord, MaxWilds: Integer; { Length of inputStr and Wilds }
  1225. HelpWilds: string;
  1226. begin
  1227. if Wilds = inputStr then begin
  1228. Result:=True;
  1229. Exit;
  1230. end;
  1231. repeat { delete '**', because '**' = '*' }
  1232. i:=Pos('**', Wilds);
  1233. if i > 0 then
  1234. Wilds:=Copy(Wilds, 1, i - 1) + '*' + Copy(Wilds, i + 2, Maxint);
  1235. until i = 0;
  1236. if Wilds = '*' then begin { for fast end, if Wilds only '*' }
  1237. Result:=True;
  1238. Exit;
  1239. end;
  1240. MaxinputWord:=Length(inputStr);
  1241. MaxWilds:=Length(Wilds);
  1242. if ignoreCase then begin { upcase all letters }
  1243. inputStr:=AnsiUpperCase(inputStr);
  1244. Wilds:=AnsiUpperCase(Wilds);
  1245. end;
  1246. if (MaxWilds = 0) or (MaxinputWord = 0) then begin
  1247. Result:=False;
  1248. Exit;
  1249. end;
  1250. CinputWord:=1;
  1251. CWild:=1;
  1252. Result:=True;
  1253. repeat
  1254. if inputStr[CinputWord] = Wilds[CWild] then begin { equal letters }
  1255. { goto next letter }
  1256. inc(CWild);
  1257. inc(CinputWord);
  1258. Continue;
  1259. end;
  1260. if Wilds[CWild] = '?' then begin { equal to '?' }
  1261. { goto next letter }
  1262. inc(CWild);
  1263. inc(CinputWord);
  1264. Continue;
  1265. end;
  1266. if Wilds[CWild] = '*' then begin { handling of '*' }
  1267. HelpWilds:=Copy(Wilds, CWild + 1, MaxWilds);
  1268. i:=SearchNext(HelpWilds);
  1269. LenHelpWilds:=Length(HelpWilds);
  1270. if i = 0 then begin
  1271. { no '*' in the rest, compare the ends }
  1272. if HelpWilds = '' then Exit; { '*' is the last letter }
  1273. { check the rest for equal Length and no '?' }
  1274. for i:=0 to LenHelpWilds - 1 do begin
  1275. if (HelpWilds[LenHelpWilds - i] <> inputStr[MaxinputWord - i]) and
  1276. (HelpWilds[LenHelpWilds - i]<> '?') then
  1277. begin
  1278. Result:=False;
  1279. Exit;
  1280. end;
  1281. end;
  1282. Exit;
  1283. end;
  1284. { handle all to the next '*' }
  1285. inc(CWild, 1 + LenHelpWilds);
  1286. i:=FindPart(HelpWilds, Copy(inputStr, CinputWord, Maxint));
  1287. if i= 0 then begin
  1288. Result:=False;
  1289. Exit;
  1290. end;
  1291. CinputWord:=i + LenHelpWilds;
  1292. Continue;
  1293. end;
  1294. Result:=False;
  1295. Exit;
  1296. until (CinputWord > MaxinputWord) or (CWild > MaxWilds);
  1297. { no completed evaluation }
  1298. if CinputWord <= MaxinputWord then Result:=False;
  1299. if (CWild <= MaxWilds) and (Wilds[MaxWilds] <> '*') then Result:=False;
  1300. end;
  1301. function XorString(const Key, Src: ShortString): ShortString;
  1302. var
  1303. i: Integer;
  1304. begin
  1305. Result:=Src;
  1306. if Length(Key) > 0 then
  1307. for i:=1 to Length(Src) do
  1308. Result[i]:=Chr(Byte(Key[1 + ((i - 1) mod Length(Key))]) xor Ord(Src[i]));
  1309. end;
  1310. function XorEncode(const Key, Source: string): string;
  1311. var
  1312. i: Integer;
  1313. C: Byte;
  1314. begin
  1315. Result:='';
  1316. for i:=1 to Length(Source) do
  1317. begin
  1318. if Length(Key) > 0 then
  1319. C:=Byte(Key[1 + ((i - 1) mod Length(Key))]) xor Byte(Source[i])
  1320. else
  1321. C:=Byte(Source[i]);
  1322. Result:=Result+AnsiLowerCase(intToHex(C, 2));
  1323. end;
  1324. end;
  1325. function XorDecode(const Key, Source: string): string;
  1326. var
  1327. i: Integer;
  1328. C: Char;
  1329. begin
  1330. Result:='';
  1331. for i:=0 to Length(Source) div 2 - 1 do
  1332. begin
  1333. C:=Chr(StrTointDef('$' + Copy(Source, (i * 2) + 1, 2), Ord(' ')));
  1334. if Length(Key) > 0 then
  1335. C:=Chr(Byte(Key[1 + (i mod Length(Key))]) xor Byte(C));
  1336. Result:=Result + C;
  1337. end;
  1338. end;
  1339. function GetCmdLineArg(const Switch: string; SwitchChars: TSysCharSet): string;
  1340. var
  1341. i: Integer;
  1342. S: string;
  1343. begin
  1344. i:=1;
  1345. Result:='';
  1346. while (Result='') and (i<=ParamCount) do
  1347. begin
  1348. S:=ParamStr(i);
  1349. if (SwitchChars=[]) or ((S[1] in SwitchChars) and (Length(S) > 1)) and
  1350. (AnsiCompareText(Copy(S,2,Length(S)-1),Switch)=0) then
  1351. begin
  1352. inc(i);
  1353. if i<=ParamCount then
  1354. Result:=ParamStr(i);
  1355. end;
  1356. inc(i);
  1357. end;
  1358. end;
  1359. Function RPosEX(C:char;const S : AnsiString;offs:cardinal):Integer; overload;
  1360. var I : SizeUInt;
  1361. p,p2: pChar;
  1362. Begin
  1363. I:=Length(S);
  1364. If (I<>0) and (offs<=i) Then
  1365. begin
  1366. p:=@s[offs];
  1367. p2:=@s[1];
  1368. while (p2<=p) and (p^<>c) do dec(p);
  1369. RPosEx:=(p-p2)+1;
  1370. end
  1371. else
  1372. RPosEX:=0;
  1373. End;
  1374. Function RPos(c:char;const S : AnsiString):Integer; overload;
  1375. var I : Integer;
  1376. p,p2: pChar;
  1377. Begin
  1378. I:=Length(S);
  1379. If I<>0 Then
  1380. begin
  1381. p:=@s[i];
  1382. p2:=@s[1];
  1383. while (p2<=p) and (p^<>c) do dec(p);
  1384. i:=p-p2+1;
  1385. end;
  1386. RPos:=i;
  1387. End;
  1388. Function RPos (Const Substr : AnsiString; Const Source : AnsiString) : Integer; overload;
  1389. var
  1390. MaxLen,llen : Integer;
  1391. c : char;
  1392. pc,pc2 : pchar;
  1393. begin
  1394. rPos:=0;
  1395. llen:=Length(SubStr);
  1396. maxlen:=length(source);
  1397. if (llen>0) and (maxlen>0) and ( llen<=maxlen) then
  1398. begin
  1399. // i:=maxlen;
  1400. pc:=@source[maxlen];
  1401. pc2:=@source[llen-1];
  1402. c:=substr[llen];
  1403. while pc>=pc2 do
  1404. begin
  1405. if (c=pc^) and
  1406. (CompareChar(Substr[1],pchar(pc-llen+1)^,Length(SubStr))=0) then
  1407. begin
  1408. rPos:=pchar(pc-llen+1)-pchar(@source[1])+1;
  1409. exit;
  1410. end;
  1411. dec(pc);
  1412. end;
  1413. end;
  1414. end;
  1415. Function RPosex (Const Substr : AnsiString; Const Source : AnsiString;offs:cardinal) : Integer; overload;
  1416. var
  1417. MaxLen,llen : Integer;
  1418. c : char;
  1419. pc,pc2 : pchar;
  1420. begin
  1421. rPosex:=0;
  1422. llen:=Length(SubStr);
  1423. maxlen:=length(source);
  1424. if SizeInt(offs)<maxlen then maxlen:=offs;
  1425. if (llen>0) and (maxlen>0) and ( llen<=maxlen) then
  1426. begin
  1427. // i:=maxlen;
  1428. pc:=@source[maxlen];
  1429. pc2:=@source[llen-1];
  1430. c:=substr[llen];
  1431. while pc>=pc2 do
  1432. begin
  1433. if (c=pc^) and
  1434. (CompareChar(Substr[1],pchar(pc-llen+1)^,Length(SubStr))=0) then
  1435. begin
  1436. rPosex:=pchar(pc-llen+1)-pchar(@source[1])+1;
  1437. exit;
  1438. end;
  1439. dec(pc);
  1440. end;
  1441. end;
  1442. end;
  1443. // def from delphi.about.com:
  1444. procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer);
  1445. Const
  1446. HexDigits='0123456789ABCDEF';
  1447. var
  1448. i : longint;
  1449. begin
  1450. for i:=0 to binbufsize-1 do
  1451. begin
  1452. HexValue[0]:=hexdigits[1+((ord(binvalue^) shr 4))];
  1453. HexValue[1]:=hexdigits[1+((ord(binvalue^) and 15))];
  1454. inc(hexvalue,2);
  1455. inc(binvalue);
  1456. end;
  1457. end;
  1458. function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer;
  1459. // more complex, have to accept more than bintohex
  1460. // A..F    1000001
  1461. // a..f    1100001
  1462. // 0..9     110000
  1463. var i,j,h,l : integer;
  1464. begin
  1465. i:=binbufsize;
  1466. while (i>0) do
  1467. begin
  1468. if hexvalue^ IN ['A'..'F','a'..'f'] then
  1469. h:=((ord(hexvalue^)+9) and 15)
  1470. else if hexvalue^ IN ['0'..'9'] then
  1471. h:=((ord(hexvalue^)) and 15)
  1472. else
  1473. break;
  1474. inc(hexvalue);
  1475. if hexvalue^ IN ['A'..'F','a'..'f'] then
  1476. l:=(ord(hexvalue^)+9) and 15
  1477. else if hexvalue^ IN ['0'..'9'] then
  1478. l:=(ord(hexvalue^)) and 15
  1479. else
  1480. break;
  1481. j := l + (h shl 4);
  1482. inc(hexvalue);
  1483. binvalue^:=chr(j);
  1484. inc(binvalue);
  1485. dec(i);
  1486. end;
  1487. result:=binbufsize-i;
  1488. end;
  1489. function possetex (const c:TSysCharSet;const s : ansistring;count:Integer ):Integer;
  1490. var i,j:Integer;
  1491. begin
  1492. if pchar(pointer(s))=nil then
  1493. j:=0
  1494. else
  1495. begin
  1496. i:=length(s);
  1497. j:=count;
  1498. if j>i then
  1499. begin
  1500. result:=0;
  1501. exit;
  1502. end;
  1503. while (j<=i) and (not (s[j] in c)) do inc(j);
  1504. if (j>i) then
  1505. j:=0; // not found.
  1506. end;
  1507. result:=j;
  1508. end;
  1509. function posset (const c:TSysCharSet;const s : ansistring ):Integer;
  1510. begin
  1511. result:=possetex(c,s,1);
  1512. end;
  1513. function possetex (const c:string;const s : ansistring;count:Integer ):Integer;
  1514. var cset : TSysCharSet;
  1515. i : integer;
  1516. begin
  1517. cset:=[];
  1518. if length(c)>0 then
  1519. for i:=1 to length(c) do
  1520. include(cset,c[i]);
  1521. result:=possetex(cset,s,count);
  1522. end;
  1523. function posset (const c:string;const s : ansistring ):Integer;
  1524. var cset : TSysCharSet;
  1525. i : integer;
  1526. begin
  1527. cset:=[];
  1528. if length(c)>0 then
  1529. for i:=1 to length(c) do
  1530. include(cset,c[i]);
  1531. result:=possetex(cset,s,1);
  1532. end;
  1533. Procedure Removeleadingchars(VAR S : AnsiString; Const CSet:TSysCharset);
  1534. VAR I,J : Longint;
  1535. Begin
  1536. I:=Length(S);
  1537. IF (I>0) Then
  1538. Begin
  1539. J:=1;
  1540. While (J<=I) And (S[J] IN CSet) DO
  1541. INC(J);
  1542. IF J>1 Then
  1543. Delete(S,1,J-1);
  1544. End;
  1545. End;
  1546. function TrimLeftSet(const S: String;const CSet:TSysCharSet): String;
  1547. begin
  1548. result:=s;
  1549. removeleadingchars(result,cset);
  1550. end;
  1551. Procedure RemoveTrailingChars(VAR S : AnsiString;Const CSet:TSysCharset);
  1552. VAR I,J: LONGINT;
  1553. Begin
  1554. I:=Length(S);
  1555. IF (I>0) Then
  1556. Begin
  1557. J:=I;
  1558. While (j>0) and (S[J] IN CSet) DO DEC(J);
  1559. IF J<>I Then
  1560. SetLength(S,J);
  1561. End;
  1562. End;
  1563. Function TrimRightSet(const S: String;const CSet:TSysCharSet): String;
  1564. begin
  1565. result:=s;
  1566. RemoveTrailingchars(result,cset);
  1567. end;
  1568. Procedure RemovePadChars(VAR S : AnsiString;Const CSet:TSysCharset);
  1569. VAR I,J,K: LONGINT;
  1570. Begin
  1571. I:=Length(S);
  1572. IF (I>0) Then
  1573. Begin
  1574. J:=I;
  1575. While (j>0) and (S[J] IN CSet) DO DEC(J);
  1576. if j=0 Then
  1577. begin
  1578. s:='';
  1579. exit;
  1580. end;
  1581. k:=1;
  1582. While (k<=I) And (S[k] IN CSet) DO
  1583. INC(k);
  1584. IF k>1 Then
  1585. begin
  1586. move(s[k],s[1],j-k+1);
  1587. setlength(s,j-k+1);
  1588. end
  1589. else
  1590. setlength(s,j);
  1591. End;
  1592. End;
  1593. function TrimSet(const S: String;const CSet:TSysCharSet): String;
  1594. begin
  1595. result:=s;
  1596. RemovePadChars(result,cset);
  1597. end;
  1598. end.