fpwidestring.pp 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832
  1. unit fpwidestring;
  2. {$mode objfpc}
  3. interface
  4. uses
  5. unicodedata;
  6. function SetActiveCollation(const AName : TCollationName) : Boolean;
  7. function SetActiveCollation(const ACollation : PUCA_DataBook) : Boolean;
  8. function GetActiveCollation() : PUCA_DataBook;
  9. var
  10. DefaultCollationName : TCollationName = '';
  11. implementation
  12. uses
  13. {$ifdef MSWINDOWS}
  14. Windows,
  15. {$endif MSWINDOWS}
  16. {$ifdef Unix}
  17. unixcp,
  18. {$endif}
  19. sysutils, character, charset;
  20. procedure fpc_rangeerror; [external name 'FPC_RANGEERROR'];
  21. {$ifdef MSWINDOWS}
  22. function GetACP:UINT; external 'kernel32' name 'GetACP';
  23. {$endif MSWINDOWS}
  24. const
  25. CharacterOptions = [TCharacterOption.coIgnoreInvalidSequence];
  26. var
  27. OldManager : TUnicodeStringManager;
  28. {$ifdef FPC_HAS_FEATURE_THREADING}
  29. ThreadVar
  30. {$else FPC_HAS_FEATURE_THREADING}
  31. Var
  32. {$endif FPC_HAS_FEATURE_THREADING}
  33. current_DefaultSystemCodePage : TSystemCodePage;
  34. current_Map : punicodemap;
  35. current_Collation : PUCA_DataBook;
  36. function SetActiveCollation(const ACollation : PUCA_DataBook) : Boolean;
  37. begin
  38. Result := (ACollation <> nil);
  39. if Result then
  40. current_Collation := ACollation;
  41. end;
  42. function SetActiveCollation(const AName : TCollationName) : Boolean;
  43. var
  44. c : PUCA_DataBook;
  45. begin
  46. c:=FindCollation(AName);
  47. Result := (c <> nil);
  48. if Result then
  49. Result := SetActiveCollation(c);
  50. end;
  51. function GetActiveCollation() : PUCA_DataBook;
  52. begin
  53. Result := current_Collation;
  54. end;
  55. {procedure error_CpNotFound(ACodePage:TSystemCodePage);
  56. begin
  57. System.error(reCodesetConversion);
  58. end;}
  59. procedure InitThread;
  60. var
  61. c : PUCA_DataBook;
  62. begin
  63. current_DefaultSystemCodePage:=DefaultSystemCodePage;
  64. current_Map:=getmap(current_DefaultSystemCodePage);
  65. c:=nil;
  66. if (DefaultCollationName<>'') then
  67. c:=FindCollation(DefaultCollationName);
  68. if (c=nil) and (GetCollationCount()>0) then
  69. c:=FindCollation(0);
  70. current_Collation:=c;
  71. end;
  72. procedure FiniThread;
  73. begin
  74. current_Map:=nil;
  75. end;
  76. { return value:
  77. -1 if incomplete or invalid code point
  78. 0 if NULL character,
  79. > 0 if that's the length in bytes of the code point }
  80. function UTF8CodePointLength(const Str: PAnsiChar; MaxLookAead: PtrInt): Ptrint;
  81. {... taken from ustrings.inc}
  82. var
  83. p: PByte;
  84. TempBYTE: Byte;
  85. CharLen: SizeUint;
  86. LookAhead: SizeUInt;
  87. UC: SizeUInt;
  88. begin
  89. if (Str=nil) then
  90. exit(0);
  91. p:=PByte(Str);
  92. if (p^=0) then
  93. exit(0);
  94. p:=PByte(Str);
  95. if (p^ and $80) = 0 then //One character US-ASCII,
  96. exit(1);
  97. TempByte:=p^;
  98. CharLen:=0;
  99. while (TempByte and $80)<>0 do
  100. begin
  101. TempByte:=(TempByte shl 1) and $FE;
  102. Inc(CharLen);
  103. end;
  104. //Test for the "CharLen" conforms UTF-8 string
  105. //This means the 10xxxxxx pattern.
  106. if SizeUInt(CharLen-1)>MaxLookAead then //Insuficient chars in string to decode UTF-8 array
  107. exit(-1);
  108. for LookAhead := 1 to CharLen-1 do
  109. begin
  110. if ((p[LookAhead] and $80)<>$80) or
  111. ((p[LookAhead] and $40)<>$00)
  112. then
  113. begin
  114. //Invalid UTF-8 sequence, fallback.
  115. exit(-1);
  116. end;
  117. end;
  118. Result:=CharLen;
  119. case CharLen of
  120. 1: begin
  121. //Not valid UTF-8 sequence
  122. Result:=-1;
  123. end;
  124. 2: begin
  125. //Two bytes UTF, convert it
  126. UC:=(p^ and $1F) shl 6;
  127. UC:=UC or (p[1] and $3F);
  128. if UC <= $7F then
  129. begin
  130. //Invalid UTF sequence.
  131. Result:=-1;
  132. end;
  133. end;
  134. 3: begin
  135. //Three bytes, convert it to unicode
  136. UC:= (p^ and $0F) shl 12;
  137. UC:= UC or ((p[1] and $3F) shl 6);
  138. UC:= UC or ((p[2] and $3F));
  139. if (UC <= $7FF) or (UC >= $FFFE) or ((UC >= $D800) and (UC <= $DFFF)) then
  140. begin
  141. //Invalid UTF-8 sequence
  142. Result:=-1;
  143. End;
  144. end;
  145. 4: begin
  146. //Four bytes, convert it to two unicode characters
  147. UC:= (p^ and $07) shl 18;
  148. UC:= UC or ((p[1] and $3F) shl 12);
  149. UC:= UC or ((p[2] and $3F) shl 6);
  150. UC:= UC or ((p[3] and $3F));
  151. if (UC < $10000) or (UC > $10FFFF) then
  152. begin
  153. Result:=-1;
  154. end
  155. end;
  156. 5,6,7: begin
  157. //Invalid UTF8 to unicode conversion,
  158. //mask it as invalid UNICODE too.
  159. Result:=-1;
  160. end;
  161. end;
  162. end;
  163. { return value:
  164. -1 if incomplete or invalid code point
  165. 0 if NULL character,
  166. > 0 if that's the length in bytes of the code point }
  167. function CodePointLength(const Str: PAnsiChar; MaxLookAead: PtrInt): PtrInt;
  168. var
  169. p : PByte;
  170. begin
  171. if (current_DefaultSystemCodePage=CP_UTF8) then
  172. exit(UTF8CodePointLength(Str,MaxLookAead));
  173. if (Str=nil) then
  174. exit(0);
  175. p:=PByte(Str);
  176. if (p^=0) then
  177. exit(0);
  178. if (current_Map=nil) then
  179. exit(1);
  180. if (p^>current_Map^.lastchar) then
  181. exit(-1);
  182. case current_Map^.map[p^].flag of
  183. umf_undefined : Result:=-1;
  184. umf_leadbyte :
  185. begin
  186. if (MaxLookAead>0) then
  187. Result:=2
  188. else
  189. Result:=-1;
  190. end;
  191. else
  192. Result:=1;
  193. end;
  194. end;
  195. procedure Unicode2AnsiMove(source:punicodechar;var dest:RawByteString;cp : TSystemCodePage;len:SizeInt);
  196. var
  197. locSource : punicodechar;
  198. locMap : punicodemap;
  199. destBuffer : PAnsiChar;
  200. destLen,actualLen, i : SizeInt;
  201. blockLen : SizeInt;
  202. begin
  203. if (len=0) then
  204. begin
  205. SetLength(dest,0);
  206. exit;
  207. end;
  208. if (cp=CP_UTF8) then
  209. begin
  210. destLen:=UnicodeToUtf8(nil,High(SizeUInt),source,len);
  211. SetLength(dest,destLen);
  212. UnicodeToUtf8(@dest[1],destLen,source,len);
  213. SetCodePage(dest,cp,False);
  214. exit;
  215. end;
  216. if (cp=CP_UTF16) then
  217. begin
  218. destLen:=len*SizeOf(UnicodeChar);
  219. SetLength(dest,destLen);
  220. Move(source^,dest[1],destLen);
  221. SetCodePage(dest,cp,False);
  222. exit;
  223. end;
  224. if (cp=DefaultSystemCodePage) then
  225. begin
  226. { update current_Map in case the DefaultSystemCodePage has been changed }
  227. if current_DefaultSystemCodePage<>DefaultSystemCodePage then
  228. begin
  229. FiniThread;
  230. InitThread;
  231. end;
  232. locMap:=current_Map;
  233. end
  234. else
  235. locMap:=getmap(cp);
  236. if (locMap=nil) then
  237. begin
  238. DefaultUnicode2AnsiMove(source,dest,DefaultSystemCodePage,len);
  239. exit;
  240. end;
  241. destLen:=3*len;
  242. SetLength(dest,destLen);
  243. destBuffer:=@dest[1];
  244. actualLen:=0;
  245. locSource:=source;
  246. for i:=1 to len do
  247. begin
  248. blockLen:=getascii(tunicodechar(locSource^),locMap,destBuffer,(destLen-actualLen));
  249. if (blockLen<0) then
  250. begin
  251. destLen:=destLen + 3*(1+len-i);
  252. SetLength(dest,destLen);
  253. destBuffer:=@dest[1];
  254. blockLen:=getascii(tunicodechar(locSource^),locMap,destBuffer,(destLen-actualLen));
  255. end;
  256. Inc(destBuffer,blockLen);
  257. actualLen:=actualLen+blockLen;
  258. Inc(locSource);
  259. end;
  260. if (actualLen<>Length(dest)) then
  261. SetLength(dest,actualLen);
  262. if (Length(dest)>0) then
  263. SetCodePage(dest,cp,False);
  264. end;
  265. procedure Ansi2UnicodeMove(source:PAnsiChar; cp:TSystemCodePage; var dest:UnicodeString; len:SizeInt);
  266. var
  267. locMap : punicodemap;
  268. destLen : SizeInt;
  269. begin
  270. if (len<=0) then
  271. begin
  272. SetLength(dest,0);
  273. exit;
  274. end;
  275. if (cp=CP_UTF8) then
  276. begin
  277. destLen:=Utf8ToUnicode(nil,source,len);
  278. if destLen > 0 then
  279. SetLength(dest,destLen-1)
  280. else
  281. SetLength(dest,0);
  282. Utf8ToUnicode(@dest[1],source,len);
  283. exit;
  284. end;
  285. if (cp=CP_UTF16) then
  286. begin
  287. //what if (len mod 2) > 0 ?
  288. destLen:=len div SizeOf(UnicodeChar);
  289. SetLength(dest,destLen);
  290. Move(source^,dest[1],(destLen*SizeOf(UnicodeChar)));
  291. exit;
  292. end;
  293. if (cp=DefaultSystemCodePage) then
  294. begin
  295. { update current_Map in case the DefaultSystemCodePage has been changed }
  296. if current_DefaultSystemCodePage<>DefaultSystemCodePage then
  297. begin
  298. FiniThread;
  299. InitThread;
  300. end;
  301. locMap:=current_Map;
  302. end
  303. else
  304. locMap:=getmap(cp);
  305. if (locMap=nil) then
  306. begin
  307. DefaultAnsi2UnicodeMove(source,DefaultSystemCodePage,dest,len);
  308. exit;
  309. end;
  310. destLen:=getunicode(source,len,locMap,nil);
  311. SetLength(dest,destLen);
  312. getunicode(source,len,locMap,tunicodestring(@dest[1]));
  313. end;
  314. {$ifdef MSWINDOWS}
  315. procedure Ansi2WideMove(source:PAnsiChar; cp:TSystemCodePage; var dest:WideString; len:SizeInt);
  316. var
  317. locMap : punicodemap;
  318. destLen : SizeInt;
  319. begin
  320. if (len<=0) then
  321. begin
  322. SetLength(dest,0);
  323. exit;
  324. end;
  325. if (cp=DefaultSystemCodePage) then
  326. begin
  327. { update current_Map in case the DefaultSystemCodePage has been changed }
  328. if current_DefaultSystemCodePage<>DefaultSystemCodePage then
  329. begin
  330. FiniThread;
  331. InitThread;
  332. end;
  333. locMap:=current_Map;
  334. end
  335. else
  336. locMap:=getmap(cp);
  337. if (locMap=nil) then
  338. begin
  339. DefaultAnsi2WideMove(source,DefaultSystemCodePage,dest,len);
  340. exit;
  341. end;
  342. destLen:=getunicode(source,len,locMap,nil);
  343. SetLength(dest,destLen);
  344. getunicode(source,len,locMap,tunicodestring(@dest[1]));
  345. end;
  346. {$endif MSWINDOWS}
  347. function UpperUnicodeString(const S: UnicodeString): UnicodeString;
  348. begin
  349. Result:=TCharacter.ToUpper(s,CharacterOptions);
  350. end;
  351. function UpperWideString(const S: WideString): WideString;
  352. var
  353. u : UnicodeString;
  354. begin
  355. u:=s;
  356. Result:=UpperUnicodeString(u);
  357. end;
  358. function LowerUnicodeString(const S: UnicodeString): UnicodeString;
  359. begin
  360. Result:=TCharacter.ToLower(s,CharacterOptions);
  361. end;
  362. function LowerWideString(const S: WideString): WideString;
  363. var
  364. u : UnicodeString;
  365. begin
  366. u:=s;
  367. Result:=LowerUnicodeString(u);
  368. end;
  369. function CompareUnicodeStringUCA(p1,p2:PUnicodeChar; l1,l2:PtrInt) : PtrInt;
  370. var
  371. k1, k2 : TUCASortKey;
  372. begin
  373. k1 := ComputeSortKey(p1,l1,current_Collation);
  374. k2 := ComputeSortKey(p2,l2,current_Collation);
  375. Result := CompareSortKey(k1,k2);
  376. end;
  377. function CompareUnicodeString(p1,p2:PUnicodeChar; l1,l2:PtrInt) : PtrInt;
  378. begin
  379. if (Pointer(p1)=Pointer(p2)) then
  380. exit(0);
  381. if (l1=0) then
  382. exit(-l2);
  383. if (l2=0) then
  384. exit(l1);
  385. Result := CompareUnicodeStringUCA(p1,p2,l1,l2);
  386. end;
  387. function CompareUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
  388. begin
  389. if (current_Collation=nil) then
  390. exit(OldManager.CompareUnicodeStringProc(s1,s2));
  391. Result:=CompareUnicodeString(
  392. PUnicodeChar(Pointer(s1)),
  393. PUnicodeChar(Pointer(s2)),
  394. Length(s1),Length(s2)
  395. );
  396. end;
  397. function CompareWideString(const s1, s2 : WideString) : PtrInt;
  398. begin
  399. if (current_Collation=nil) then
  400. exit(OldManager.CompareWideStringProc(s1,s2));
  401. Result:=CompareUnicodeString(
  402. PUnicodeChar(Pointer(s1)),
  403. PUnicodeChar(Pointer(s2)),
  404. Length(s1),Length(s2)
  405. );
  406. end;
  407. function CompareTextUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
  408. begin
  409. Result:=CompareUnicodeString(UpperUnicodeString(s1),UpperUnicodeString(s2));
  410. end;
  411. function CompareTextWideString(const s1, s2 : WideString) : PtrInt;
  412. begin
  413. Result:=CompareWideString(UpperWideString(s1),UpperWideString(s2));
  414. end;
  415. procedure EnsureAnsiLen(var S: AnsiString; const len: SizeInt); inline;
  416. begin
  417. if (len>length(s)) then
  418. if (length(s) < 10*256) then
  419. setlength(s,length(s)+10)
  420. else
  421. setlength(s,length(s)+length(s) shr 8);
  422. end;
  423. procedure ConcatCharToAnsiStr(const c: AnsiChar; var S: AnsiString; var index: SizeInt);
  424. begin
  425. EnsureAnsiLen(s,index);
  426. pansichar(@s[index])^:=c;
  427. inc(index);
  428. end;
  429. function UpperAnsiString(const s : ansistring) : ansistring;
  430. var
  431. p : PAnsiChar;
  432. i, slen,
  433. resindex : SizeInt;
  434. mblen : SizeInt;
  435. us,usl : UnicodeString;
  436. locMap : punicodemap;
  437. ulen,k,
  438. aalen,ai : SizeInt;
  439. aa : array[0..8] of AnsiChar;
  440. begin
  441. if (Length(s)=0) then
  442. exit('');
  443. if (DefaultSystemCodePage=CP_UTF8) then
  444. begin
  445. //convert to UnicodeString,uppercase,convert back to utf8
  446. ulen:=Utf8ToUnicode(nil,@s[1],Length(s));
  447. if ulen>0 then
  448. SetLength(us,ulen-1);
  449. Utf8ToUnicode(@us[1],@s[1],Length(s));
  450. us:=UpperUnicodeString(us);
  451. ulen:=Length(us);
  452. slen:=UnicodeToUtf8(nil,0,@us[1],ulen);
  453. SetLength(Result,slen);
  454. UnicodeToUtf8(@Result[1],slen,@us[1],ulen);
  455. exit;
  456. end;
  457. if current_DefaultSystemCodePage<>DefaultSystemCodePage then
  458. begin
  459. FiniThread;
  460. InitThread;
  461. end;
  462. locMap:=current_Map;
  463. if (locMap=nil) then
  464. exit(System.UpCase(s));
  465. SetLength(us,2);
  466. p:=@s[1];
  467. slen:=length(s);
  468. SetLength(result,slen+10);
  469. i:=1;
  470. resindex:=1;
  471. while (i<=slen) do
  472. begin
  473. mblen:=CodePointLength(p,slen-i);
  474. if (mblen<=0) then
  475. begin
  476. ConcatCharToAnsiStr(p^,result,resindex);
  477. mblen:=1;
  478. end
  479. else
  480. begin
  481. SetLength(us,2);
  482. ulen:=getunicode(p,mblen,locMap,@us[1]);
  483. if (Length(us)<>ulen) then
  484. SetLength(us,ulen);
  485. usl:=TCharacter.ToUpper(us,CharacterOptions);
  486. for k:=1 to Length(usl) do
  487. begin
  488. aalen:=getascii(tunicodechar(us[k]),locMap,@aa[Low(aa)],Length(aa));
  489. for ai:=0 to aalen-1 do
  490. ConcatCharToAnsiStr(aa[ai],result,resindex);
  491. end;
  492. end;
  493. Inc(p,mblen);
  494. end;
  495. SetLength(result,resindex-1);
  496. end;
  497. function LowerAnsiString(const s : ansistring) : ansistring;
  498. var
  499. p : PAnsiChar;
  500. i, slen,
  501. resindex : SizeInt;
  502. mblen : SizeInt;
  503. us,usl : UnicodeString;
  504. locMap : punicodemap;
  505. ulen,k,
  506. aalen,ai : SizeInt;
  507. aa : array[0..8] of AnsiChar;
  508. begin
  509. if (Length(s)=0) then
  510. exit('');
  511. if (DefaultSystemCodePage=CP_UTF8) then
  512. begin
  513. //convert to UnicodeString,lowercase,convert back to utf8
  514. ulen:=Utf8ToUnicode(nil,@s[1],Length(s));
  515. if ulen>0 then
  516. SetLength(us,ulen-1);
  517. Utf8ToUnicode(@us[1],@s[1],Length(s));
  518. us:=LowerUnicodeString(us);
  519. ulen:=Length(us);
  520. slen:=UnicodeToUtf8(nil,0,@us[1],ulen);
  521. SetLength(Result,slen);
  522. UnicodeToUtf8(@Result[1],slen,@us[1],ulen);
  523. exit;
  524. end;
  525. if current_DefaultSystemCodePage<>DefaultSystemCodePage then
  526. begin
  527. FiniThread;
  528. InitThread;
  529. end;
  530. locMap:=current_Map;
  531. if (locMap=nil) then
  532. exit(System.LowerCase(s));
  533. SetLength(us,2);
  534. p:=@s[1];
  535. slen:=length(s);
  536. SetLength(result,slen+10);
  537. i:=1;
  538. resindex:=1;
  539. while (i<=slen) do
  540. begin
  541. mblen:=CodePointLength(p,slen-i);
  542. if (mblen<=0) then
  543. begin
  544. ConcatCharToAnsiStr(p^,result,resindex);
  545. mblen:=1;
  546. end
  547. else
  548. begin
  549. SetLength(us,2);
  550. ulen:=getunicode(p,mblen,locMap,@us[1]);
  551. if (Length(us)<>ulen) then
  552. SetLength(us,ulen);
  553. usl:=TCharacter.ToLower(us,CharacterOptions);
  554. for k:=1 to Length(usl) do
  555. begin
  556. aalen:=getascii(tunicodechar(us[k]),locMap,@aa[Low(aa)],Length(aa));
  557. for ai:=0 to aalen-1 do
  558. ConcatCharToAnsiStr(aa[ai],result,resindex);
  559. end;
  560. end;
  561. Inc(p,mblen);
  562. end;
  563. SetLength(result,resindex-1);
  564. end;
  565. procedure ansi2pchar(const s: ansistring; const orgp: pansichar; out p: pansichar);
  566. var
  567. newlen: sizeint;
  568. begin
  569. newlen:=length(s);
  570. if newlen>strlen(orgp) then
  571. fpc_rangeerror;
  572. p:=orgp;
  573. if (newlen>0) then
  574. move(s[1],p[0],newlen);
  575. p[newlen]:=#0;
  576. end;
  577. function AnsiStrLower(Str: PAnsiChar): PAnsiChar;
  578. var
  579. temp: ansistring;
  580. begin
  581. temp:=LowerAnsiString(str);
  582. ansi2pchar(temp,str,result);
  583. end;
  584. function AnsiStrUpper(Str: PAnsiChar): PAnsiChar;
  585. var
  586. temp: ansistring;
  587. begin
  588. temp:=UpperAnsiString(str);
  589. ansi2pchar(temp,str,result);
  590. end;
  591. function CharLengthPChar(const Str: PAnsiChar): PtrInt;
  592. var
  593. len:PtrInt;
  594. nextlen: ptrint;
  595. s: PAnsiChar;
  596. begin
  597. Result:=0;
  598. if (Str=nil) or (Byte(Str^)=0) then
  599. exit;
  600. s:=str;
  601. len:=strlen(s);
  602. repeat
  603. nextlen:=CodePointLength(s,len);
  604. { skip invalid/incomplete sequences }
  605. if (nextlen<0) then
  606. nextlen:=1;
  607. Inc(result,nextlen);
  608. Inc(s,nextlen);
  609. Dec(len,nextlen);
  610. until (nextlen=0);
  611. end;
  612. function InternalCompareStrAnsiString(
  613. const S1, S2 : PAnsiChar;
  614. const Len1, Len2 : PtrUInt
  615. ) : PtrInt;inline;
  616. var
  617. a, b : UnicodeString;
  618. begin
  619. a := '';
  620. Ansi2UnicodeMove(S1,DefaultSystemCodePage,a,Len1);
  621. b := '';
  622. Ansi2UnicodeMove(S2,DefaultSystemCodePage,b,Len2);
  623. Result := CompareUnicodeString(a,b);
  624. end;
  625. function StrLCompAnsiString(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt;
  626. begin
  627. if (MaxLen=0) then
  628. exit(0);
  629. Result := InternalCompareStrAnsiString(S1,S2,MaxLen,MaxLen);
  630. end;
  631. function CompareStrAnsiString(const S1, S2: ansistring): PtrInt;
  632. var
  633. l1, l2 : PtrInt;
  634. begin
  635. if (Pointer(S1)=Pointer(S2)) then
  636. exit(0);
  637. l1:=Length(S1);
  638. l2:=Length(S2);
  639. if (l1=0) then begin
  640. if (l2=0) then
  641. exit(0);
  642. exit(-l2);
  643. end;
  644. if (l2=0) then
  645. exit(-l1);
  646. Result := InternalCompareStrAnsiString(@S1[1],@S2[2],l1,l2);
  647. end;
  648. function CompareTextAnsiString(const S1, S2: ansistring): PtrInt;
  649. var
  650. a,b : ansistring;
  651. begin
  652. a:=UpperAnsistring(s1);
  653. b:=UpperAnsistring(s2);
  654. Result:=CompareStrAnsiString(a,b);
  655. end;
  656. function StrCompAnsiString(S1, S2: PChar): PtrInt;
  657. var
  658. l1,l2,l : PtrInt;
  659. begin
  660. l1:=strlen(S1);
  661. l2:=strlen(S2);
  662. Result := InternalCompareStrAnsiString(S1,S2,l1,l2);
  663. end;
  664. function StrLICompAnsiString(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  665. var
  666. a, b: ansistring;
  667. begin
  668. if (MaxLen=0) then
  669. exit(0);
  670. SetLength(a,MaxLen);
  671. Move(s1^,a[1],MaxLen);
  672. SetLength(b,MaxLen);
  673. Move(s2^,b[1],MaxLen);
  674. Result:=CompareTextAnsiString(a,b);
  675. end;
  676. function StrICompAnsiString(S1, S2: PChar): PtrInt;
  677. begin
  678. Result:=CompareTextAnsiString(ansistring(s1),ansistring(s2));
  679. end;
  680. function StrLowerAnsiString(Str: PChar): PChar;
  681. var
  682. temp: ansistring;
  683. begin
  684. temp:=LowerAnsiString(str);
  685. ansi2pchar(temp,str,result);
  686. end;
  687. function StrUpperAnsiString(Str: PChar): PChar;
  688. var
  689. temp: ansistring;
  690. begin
  691. temp:=UpperAnsiString(str);
  692. ansi2pchar(temp,str,result);
  693. end;
  694. //------------------------------------------------------------------------------
  695. procedure SetPascalWideStringManager();
  696. var
  697. locWideStringManager : TUnicodeStringManager;
  698. begin
  699. OldManager := widestringmanager;
  700. locWideStringManager:=widestringmanager;
  701. With locWideStringManager do
  702. begin
  703. Wide2AnsiMoveProc:=@Unicode2AnsiMove;
  704. {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
  705. Ansi2WideMoveProc:=@Ansi2WideMove;
  706. UpperWideStringProc:=@UpperWideString;
  707. LowerWideStringProc:=@LowerWideString;
  708. CompareWideStringProc:=@CompareWideString;
  709. CompareTextWideStringProc:=@CompareTextWideString;
  710. {$else FPC_WIDESTRING_EQUAL_UNICODESTRING}
  711. Ansi2WideMoveProc:=@Ansi2UnicodeMove;
  712. UpperWideStringProc:=@UpperUnicodeString;
  713. LowerWideStringProc:=@LowerUnicodeString;
  714. CompareWideStringProc:=@CompareUnicodeString;
  715. CompareTextWideStringProc:=@CompareTextUnicodeString;
  716. {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
  717. CharLengthPCharProc:=@CharLengthPChar;
  718. CodePointLengthProc:=@CodePointLength;
  719. UpperAnsiStringProc:=@UpperAnsiString;
  720. LowerAnsiStringProc:=@LowerAnsiString;
  721. CompareStrAnsiStringProc:=@CompareStrAnsiString;
  722. CompareTextAnsiStringProc:=@CompareTextAnsiString;
  723. StrCompAnsiStringProc:=@StrCompAnsiString;
  724. StrICompAnsiStringProc:=@StrICompAnsiString;
  725. StrLCompAnsiStringProc:=@StrLCompAnsiString;
  726. StrLICompAnsiStringProc:=@StrLICompAnsiString;
  727. StrLowerAnsiStringProc:=@StrLowerAnsiString;
  728. StrUpperAnsiStringProc:=@StrUpperAnsiString;
  729. ThreadInitProc:=@InitThread;
  730. ThreadFiniProc:=@FiniThread;
  731. { Unicode }
  732. Unicode2AnsiMoveProc:=@Unicode2AnsiMove;
  733. Ansi2UnicodeMoveProc:=@Ansi2UnicodeMove;
  734. UpperUnicodeStringProc:=@UpperUnicodeString;
  735. LowerUnicodeStringProc:=@LowerUnicodeString;
  736. CompareUnicodeStringProc:=@CompareUnicodeString;
  737. CompareTextUnicodeStringProc:=@CompareTextUnicodeString;
  738. end;
  739. SetUnicodeStringManager(locWideStringManager);
  740. DefaultUnicodeCodePage:=CP_UTF16;
  741. {$ifdef MSWINDOWS}
  742. DefaultSystemCodePage:=GetACP();
  743. {$endif MSWINDOWS}
  744. {$ifdef UNIX}
  745. DefaultSystemCodePage:=GetSystemCodepage;
  746. if (DefaultSystemCodePage = CP_NONE) then
  747. DefaultSystemCodePage:=CP_UTF8;
  748. {$endif UNIX}
  749. end;
  750. initialization
  751. current_Collation := nil;
  752. SetPascalWideStringManager();
  753. InitThread();
  754. finalization
  755. FiniThread();
  756. end.