fpwidestring.pp 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819
  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) : PtrInt;
  369. begin
  370. if (current_Collation=nil) then
  371. exit(OldManager.CompareUnicodeStringProc(s1,s2));
  372. Result:=CompareUnicodeString(
  373. PUnicodeChar(Pointer(s1)),
  374. PUnicodeChar(Pointer(s2)),
  375. Length(s1),Length(s2)
  376. );
  377. end;
  378. function CompareWideString(const s1, s2 : WideString) : PtrInt;
  379. begin
  380. if (current_Collation=nil) then
  381. exit(OldManager.CompareWideStringProc(s1,s2));
  382. Result:=CompareUnicodeString(
  383. PUnicodeChar(Pointer(s1)),
  384. PUnicodeChar(Pointer(s2)),
  385. Length(s1),Length(s2)
  386. );
  387. end;
  388. function CompareTextUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
  389. begin
  390. Result:=CompareUnicodeString(UpperUnicodeString(s1),UpperUnicodeString(s2));
  391. end;
  392. function CompareTextWideString(const s1, s2 : WideString) : PtrInt;
  393. begin
  394. Result:=CompareWideString(UpperWideString(s1),UpperWideString(s2));
  395. end;
  396. procedure EnsureAnsiLen(var S: AnsiString; const len: SizeInt); inline;
  397. begin
  398. if (len>length(s)) then
  399. if (length(s) < 10*256) then
  400. setlength(s,length(s)+10)
  401. else
  402. setlength(s,length(s)+length(s) shr 8);
  403. end;
  404. procedure ConcatCharToAnsiStr(const c: AnsiChar; var S: AnsiString; var index: SizeInt);
  405. begin
  406. EnsureAnsiLen(s,index);
  407. pansichar(@s[index])^:=c;
  408. inc(index);
  409. end;
  410. function UpperAnsiString(const s : ansistring) : ansistring;
  411. var
  412. p : PAnsiChar;
  413. i, slen,
  414. resindex : SizeInt;
  415. mblen : SizeInt;
  416. us,usl : UnicodeString;
  417. locMap : punicodemap;
  418. ulen,k,
  419. aalen,ai : SizeInt;
  420. aa : array[0..8] of AnsiChar;
  421. begin
  422. if (Length(s)=0) then
  423. exit('');
  424. if (DefaultSystemCodePage=CP_UTF8) then
  425. begin
  426. //convert to UnicodeString,uppercase,convert back to utf8
  427. ulen:=Utf8ToUnicode(nil,@s[1],Length(s));
  428. if ulen>0 then
  429. SetLength(us,ulen-1);
  430. Utf8ToUnicode(@us[1],@s[1],Length(s));
  431. us:=UpperUnicodeString(us);
  432. ulen:=Length(us);
  433. slen:=UnicodeToUtf8(nil,0,@us[1],ulen);
  434. SetLength(Result,slen);
  435. UnicodeToUtf8(@Result[1],slen,@us[1],ulen);
  436. exit;
  437. end;
  438. locMap:=FindMap(DefaultSystemCodePage);
  439. if (locMap=nil) then
  440. exit(System.UpCase(s));
  441. SetLength(us,2);
  442. p:=@s[1];
  443. slen:=length(s);
  444. SetLength(result,slen+10);
  445. i:=1;
  446. resindex:=1;
  447. while (i<=slen) do
  448. begin
  449. mblen:=CodePointLength(p,slen-i);
  450. if (mblen<=0) then
  451. begin
  452. ConcatCharToAnsiStr(p^,result,resindex);
  453. mblen:=1;
  454. end
  455. else
  456. begin
  457. SetLength(us,2);
  458. ulen:=getunicode(p,mblen,locMap,@us[1]);
  459. if (Length(us)<>ulen) then
  460. SetLength(us,ulen);
  461. usl:=UpperUnicodeString(us);
  462. for k:=1 to Length(usl) do
  463. begin
  464. aalen:=getascii(tunicodechar(us[k]),locMap,@aa[Low(aa)],Length(aa));
  465. for ai:=0 to aalen-1 do
  466. ConcatCharToAnsiStr(aa[ai],result,resindex);
  467. end;
  468. end;
  469. Inc(p,mblen);
  470. end;
  471. SetLength(result,resindex-1);
  472. end;
  473. function LowerAnsiString(const s : ansistring) : ansistring;
  474. var
  475. p : PAnsiChar;
  476. i, slen,
  477. resindex : SizeInt;
  478. mblen : SizeInt;
  479. us,usl : UnicodeString;
  480. locMap : punicodemap;
  481. ulen,k,
  482. aalen,ai : SizeInt;
  483. aa : array[0..8] of AnsiChar;
  484. begin
  485. if (Length(s)=0) then
  486. exit('');
  487. if (DefaultSystemCodePage=CP_UTF8) then
  488. begin
  489. //convert to UnicodeString,lowercase,convert back to utf8
  490. ulen:=Utf8ToUnicode(nil,@s[1],Length(s));
  491. if ulen>0 then
  492. SetLength(us,ulen-1);
  493. Utf8ToUnicode(@us[1],@s[1],Length(s));
  494. us:=LowerUnicodeString(us);
  495. ulen:=Length(us);
  496. slen:=UnicodeToUtf8(nil,0,@us[1],ulen);
  497. SetLength(Result,slen);
  498. UnicodeToUtf8(@Result[1],slen,@us[1],ulen);
  499. exit;
  500. end;
  501. locMap:=FindMap(DefaultSystemCodePage);
  502. if (locMap=nil) then
  503. exit(System.LowerCase(s));
  504. SetLength(us,2);
  505. p:=@s[1];
  506. slen:=length(s);
  507. SetLength(result,slen+10);
  508. i:=1;
  509. resindex:=1;
  510. while (i<=slen) do
  511. begin
  512. mblen:=CodePointLength(p,slen-i);
  513. if (mblen<=0) then
  514. begin
  515. ConcatCharToAnsiStr(p^,result,resindex);
  516. mblen:=1;
  517. end
  518. else
  519. begin
  520. SetLength(us,2);
  521. ulen:=getunicode(p,mblen,locMap,@us[1]);
  522. if (Length(us)<>ulen) then
  523. SetLength(us,ulen);
  524. usl:=LowerUnicodeString(us);
  525. for k:=1 to Length(usl) do
  526. begin
  527. aalen:=getascii(tunicodechar(us[k]),locMap,@aa[Low(aa)],Length(aa));
  528. for ai:=0 to aalen-1 do
  529. ConcatCharToAnsiStr(aa[ai],result,resindex);
  530. end;
  531. end;
  532. Inc(p,mblen);
  533. end;
  534. SetLength(result,resindex-1);
  535. end;
  536. procedure ansi2pchar(const s: ansistring; const orgp: pansichar; out p: pansichar);
  537. var
  538. newlen: sizeint;
  539. begin
  540. newlen:=length(s);
  541. if newlen>strlen(orgp) then
  542. fpc_rangeerror;
  543. p:=orgp;
  544. if (newlen>0) then
  545. move(s[1],p[0],newlen);
  546. p[newlen]:=#0;
  547. end;
  548. function AnsiStrLower(Str: PAnsiChar): PAnsiChar;
  549. var
  550. temp: ansistring;
  551. begin
  552. temp:=LowerAnsiString(str);
  553. ansi2pchar(temp,str,result);
  554. end;
  555. function AnsiStrUpper(Str: PAnsiChar): PAnsiChar;
  556. var
  557. temp: ansistring;
  558. begin
  559. temp:=UpperAnsiString(str);
  560. ansi2pchar(temp,str,result);
  561. end;
  562. function CharLengthPChar(const Str: PAnsiChar): PtrInt;
  563. var
  564. len:PtrInt;
  565. nextlen: ptrint;
  566. s: PAnsiChar;
  567. begin
  568. Result:=0;
  569. if (Str=nil) or (Byte(Str^)=0) then
  570. exit;
  571. s:=str;
  572. len:=strlen(s);
  573. repeat
  574. nextlen:=CodePointLength(s,len);
  575. { skip invalid/incomplete sequences }
  576. if (nextlen<0) then
  577. nextlen:=1;
  578. Inc(result,nextlen);
  579. Inc(s,nextlen);
  580. Dec(len,nextlen);
  581. until (nextlen=0);
  582. end;
  583. function InternalCompareStrAnsiString(
  584. const S1, S2 : PAnsiChar;
  585. const Len1, Len2 : PtrUInt
  586. ) : PtrInt;inline;
  587. var
  588. a, b : UnicodeString;
  589. begin
  590. a := '';
  591. Ansi2UnicodeMove(S1,DefaultSystemCodePage,a,Len1);
  592. b := '';
  593. Ansi2UnicodeMove(S2,DefaultSystemCodePage,b,Len2);
  594. Result := CompareUnicodeString(a,b);
  595. end;
  596. function StrLCompAnsiString(S1, S2: PAnsiChar; MaxLen: PtrUInt): PtrInt;
  597. begin
  598. if (MaxLen=0) then
  599. exit(0);
  600. Result := InternalCompareStrAnsiString(S1,S2,MaxLen,MaxLen);
  601. end;
  602. function CompareStrAnsiString(const S1, S2: ansistring): PtrInt;
  603. var
  604. l1, l2 : PtrInt;
  605. begin
  606. if (Pointer(S1)=Pointer(S2)) then
  607. exit(0);
  608. l1:=Length(S1);
  609. l2:=Length(S2);
  610. if (l1=0) then begin
  611. if (l2=0) then
  612. exit(0);
  613. exit(-l2);
  614. end;
  615. if (l2=0) then
  616. exit(-l1);
  617. Result := InternalCompareStrAnsiString(@S1[1],@S2[2],l1,l2);
  618. end;
  619. function CompareTextAnsiString(const S1, S2: ansistring): PtrInt;
  620. var
  621. a,b : ansistring;
  622. begin
  623. a:=UpperAnsistring(s1);
  624. b:=UpperAnsistring(s2);
  625. Result:=CompareStrAnsiString(a,b);
  626. end;
  627. function StrCompAnsiString(S1, S2: PChar): PtrInt;
  628. var
  629. l1,l2 : PtrInt;
  630. begin
  631. l1:=strlen(S1);
  632. l2:=strlen(S2);
  633. Result := InternalCompareStrAnsiString(S1,S2,l1,l2);
  634. end;
  635. function StrLICompAnsiString(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
  636. var
  637. a, b: ansistring;
  638. begin
  639. if (MaxLen=0) then
  640. exit(0);
  641. SetLength(a,MaxLen);
  642. Move(s1^,a[1],MaxLen);
  643. SetLength(b,MaxLen);
  644. Move(s2^,b[1],MaxLen);
  645. Result:=CompareTextAnsiString(a,b);
  646. end;
  647. function StrICompAnsiString(S1, S2: PChar): PtrInt;
  648. begin
  649. Result:=CompareTextAnsiString(ansistring(s1),ansistring(s2));
  650. end;
  651. function StrLowerAnsiString(Str: PChar): PChar;
  652. var
  653. temp: ansistring;
  654. begin
  655. temp:=LowerAnsiString(str);
  656. ansi2pchar(temp,str,result);
  657. end;
  658. function StrUpperAnsiString(Str: PChar): PChar;
  659. var
  660. temp: ansistring;
  661. begin
  662. temp:=UpperAnsiString(str);
  663. ansi2pchar(temp,str,result);
  664. end;
  665. //------------------------------------------------------------------------------
  666. procedure SetPascalWideStringManager();
  667. var
  668. locWideStringManager : TUnicodeStringManager;
  669. begin
  670. OldManager := widestringmanager;
  671. locWideStringManager:=widestringmanager;
  672. With locWideStringManager do
  673. begin
  674. Wide2AnsiMoveProc:=@Unicode2AnsiMove;
  675. {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
  676. Ansi2WideMoveProc:=@Ansi2WideMove;
  677. UpperWideStringProc:=@UpperWideString;
  678. LowerWideStringProc:=@LowerWideString;
  679. CompareWideStringProc:=@CompareWideString;
  680. CompareTextWideStringProc:=@CompareTextWideString;
  681. {$else FPC_WIDESTRING_EQUAL_UNICODESTRING}
  682. Ansi2WideMoveProc:=@Ansi2UnicodeMove;
  683. UpperWideStringProc:=@UpperUnicodeString;
  684. LowerWideStringProc:=@LowerUnicodeString;
  685. CompareWideStringProc:=@CompareUnicodeString;
  686. CompareTextWideStringProc:=@CompareTextUnicodeString;
  687. {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
  688. CharLengthPCharProc:=@CharLengthPChar;
  689. CodePointLengthProc:=@CodePointLength;
  690. UpperAnsiStringProc:=@UpperAnsiString;
  691. LowerAnsiStringProc:=@LowerAnsiString;
  692. CompareStrAnsiStringProc:=@CompareStrAnsiString;
  693. CompareTextAnsiStringProc:=@CompareTextAnsiString;
  694. StrCompAnsiStringProc:=@StrCompAnsiString;
  695. StrICompAnsiStringProc:=@StrICompAnsiString;
  696. StrLCompAnsiStringProc:=@StrLCompAnsiString;
  697. StrLICompAnsiStringProc:=@StrLICompAnsiString;
  698. StrLowerAnsiStringProc:=@StrLowerAnsiString;
  699. StrUpperAnsiStringProc:=@StrUpperAnsiString;
  700. ThreadInitProc:=@InitThread;
  701. ThreadFiniProc:=@FiniThread;
  702. { Unicode }
  703. Unicode2AnsiMoveProc:=@Unicode2AnsiMove;
  704. Ansi2UnicodeMoveProc:=@Ansi2UnicodeMove;
  705. UpperUnicodeStringProc:=@UpperUnicodeString;
  706. LowerUnicodeStringProc:=@LowerUnicodeString;
  707. CompareUnicodeStringProc:=@CompareUnicodeString;
  708. CompareTextUnicodeStringProc:=@CompareTextUnicodeString;
  709. end;
  710. SetUnicodeStringManager(locWideStringManager);
  711. DefaultUnicodeCodePage:=CP_UTF16;
  712. {$ifdef MSWINDOWS}
  713. DefaultSystemCodePage:=GetACP();
  714. {$ELSE MSWINDOWS}
  715. {$ifdef UNIX}
  716. DefaultSystemCodePage:=GetSystemCodepage;
  717. if (DefaultSystemCodePage = CP_NONE) then
  718. DefaultSystemCodePage:=CP_UTF8;
  719. {$ifdef FPCRTL_FILESYSTEM_UTF8}
  720. DefaultFileSystemCodePage:=CP_UTF8;
  721. {$else}
  722. DefaultFileSystemCodePage:=DefaultSystemCodepage;
  723. {$endif}
  724. DefaultRTLFileSystemCodePage:=DefaultFileSystemCodePage;
  725. {$ELSE UNIX}
  726. if Assigned (WideStringManager.GetStandardCodePageProc) then
  727. DefaultSystemCodePage := WideStringManager.GetStandardCodePageProc (scpAnsi)
  728. else
  729. DefaultSystemCodePage := CP_NONE;
  730. DefaultFileSystemCodePage := DefaultSystemCodePage;
  731. DefaultRTLFileSystemCodePage := DefaultSystemCodePage;
  732. {$endif UNIX}
  733. {$endif MSWINDOWS}
  734. end;
  735. initialization
  736. current_Collation := nil;
  737. SetPascalWideStringManager();
  738. InitThread();
  739. finalization
  740. FiniThread();
  741. end.