fpwidestring.pp 20 KB

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