wstrings.inc 38 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2005 by Florian Klaempfl,
  4. member of the Free Pascal development team.
  5. This file implements support routines for WideStrings/Unicode with FPC
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {
  13. This file contains the implementation of the WideString type,
  14. and all things that are needed for it.
  15. WideString is defined as a 'silent' pwidechar :
  16. a pwidechar that points to :
  17. @-8 : SizeInt for reference count;
  18. @-4 : SizeInt for size; size=number of bytes, not the number of chars. Divide or multiply
  19. with sizeof(WideChar) to convert. This is needed to be compatible with Delphi and
  20. Windows COM BSTR.
  21. @ : String + Terminating #0;
  22. Pwidechar(Widestring) is a valid typecast.
  23. So WS[i] is converted to the address @WS+i-1.
  24. Constants should be assigned a reference count of -1
  25. Meaning that they can't be disposed of.
  26. }
  27. Type
  28. PWideRec = ^TWideRec;
  29. TWideRec = Packed Record
  30. {$ifdef FPC_WINLIKEWIDESTRING}
  31. Len : DWord;
  32. {$else FPC_WINLIKEWIDESTRING}
  33. Ref : SizeInt;
  34. Len : SizeInt;
  35. {$endif FPC_WINLIKEWIDESTRING}
  36. First : WideChar;
  37. end;
  38. Const
  39. WideRecLen = SizeOf(TWideRec);
  40. WideFirstOff = SizeOf(TWideRec)-sizeof(WideChar);
  41. {
  42. Default WideChar <-> Char conversion is to only convert the
  43. lower 127 chars, all others are translated to spaces.
  44. These routines can be overwritten for the Current Locale
  45. }
  46. procedure DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
  47. var
  48. i : SizeInt;
  49. begin
  50. setlength(dest,len);
  51. for i:=1 to len do
  52. begin
  53. if word(source^)<256 then
  54. dest[i]:=char(word(source^))
  55. else
  56. dest[i]:='?';
  57. inc(source);
  58. end;
  59. end;
  60. procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
  61. var
  62. i : SizeInt;
  63. begin
  64. setlength(dest,len);
  65. for i:=1 to len do
  66. begin
  67. dest[i]:=widechar(byte(source^));
  68. inc(source);
  69. end;
  70. end;
  71. Procedure GetWideStringManager (Var Manager : TWideStringManager);
  72. begin
  73. manager:=widestringmanager;
  74. end;
  75. Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
  76. begin
  77. Old:=widestringmanager;
  78. widestringmanager:=New;
  79. end;
  80. Procedure SetWideStringManager (Const New : TWideStringManager);
  81. begin
  82. widestringmanager:=New;
  83. end;
  84. (*
  85. Procedure UniqueWideString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
  86. {
  87. Make sure reference count of S is 1,
  88. using copy-on-write semantics.
  89. }
  90. begin
  91. end;
  92. *)
  93. {****************************************************************************
  94. Internal functions, not in interface.
  95. ****************************************************************************}
  96. procedure WideStringError;
  97. begin
  98. HandleErrorFrame(204,get_frame);
  99. end;
  100. {$ifdef WideStrDebug}
  101. Procedure DumpWideRec(S : Pointer);
  102. begin
  103. If S=Nil then
  104. Writeln ('String is nil')
  105. Else
  106. Begin
  107. With PWideRec(S-WideFirstOff)^ do
  108. begin
  109. Write ('(Len:',len);
  110. Writeln (' Ref: ',ref,')');
  111. end;
  112. end;
  113. end;
  114. {$endif}
  115. Function NewWideString(Len : SizeInt) : Pointer;
  116. {
  117. Allocate a new WideString on the heap.
  118. initialize it to zero length and reference count 1.
  119. }
  120. Var
  121. P : Pointer;
  122. begin
  123. {$ifdef MSWINDOWS}
  124. if winwidestringalloc then
  125. P:=SysAllocStringLen(nil,Len)
  126. else
  127. {$endif MSWINDOWS}
  128. begin
  129. GetMem(P,Len*sizeof(WideChar)+WideRecLen);
  130. If P<>Nil then
  131. begin
  132. PWideRec(P)^.Len:=Len*2; { Initial length }
  133. {$ifndef FPC_WINLIKEWIDESTRING}
  134. PWideRec(P)^.Ref:=1; { Initial Refcount }
  135. {$endif FPC_WINLIKEWIDESTRING}
  136. PWideRec(P)^.First:=#0; { Terminating #0 }
  137. inc(p,WideFirstOff); { Points to string now }
  138. end
  139. else
  140. WideStringError;
  141. end;
  142. NewWideString:=P;
  143. end;
  144. Procedure DisposeWideString(Var S : Pointer);
  145. {
  146. Deallocates a WideString From the heap.
  147. }
  148. begin
  149. If S=Nil then
  150. exit;
  151. {$ifndef MSWINDOWS}
  152. Dec (S,WideFirstOff);
  153. Freemem(S);
  154. {$else MSWINDOWS}
  155. if winwidestringalloc then
  156. SysFreeString(S)
  157. else
  158. begin
  159. Dec (S,WideFirstOff);
  160. Freemem(S);
  161. end;
  162. {$endif MSWINDOWS}
  163. S:=Nil;
  164. end;
  165. Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_WIDESTR_DECR_REF']; compilerproc;
  166. {
  167. Decreases the ReferenceCount of a non constant widestring;
  168. If the reference count is zero, deallocate the string;
  169. }
  170. Type
  171. pSizeInt = ^SizeInt;
  172. {$ifndef FPC_WINLIKEWIDESTRING}
  173. Var
  174. l : pSizeInt;
  175. {$endif FPC_WINLIKEWIDESTRING}
  176. Begin
  177. { Zero string }
  178. if S=Nil then
  179. exit;
  180. {$ifndef FPC_WINLIKEWIDESTRING}
  181. { check for constant strings ...}
  182. l:=@PWideRec(S-WideFirstOff)^.Ref;
  183. if l^<0 then
  184. exit;
  185. { declocked does a MT safe dec and returns true, if the counter is 0 }
  186. if declocked(l^) then
  187. { Ref count dropped to zero ...
  188. ... remove }
  189. {$endif FPC_WINLIKEWIDESTRING}
  190. DisposeWideString(S);
  191. end;
  192. { alias for internal use }
  193. Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_DECR_REF'];
  194. Procedure fpc_WideStr_Incr_Ref(Var S : Pointer);[Public,Alias:'FPC_WIDESTR_INCR_REF']; compilerproc;
  195. {$ifdef FPC_WINLIKEWIDESTRING}
  196. var
  197. p : pointer;
  198. {$endif FPC_WINLIKEWIDESTRING}
  199. Begin
  200. If S=Nil then
  201. exit;
  202. {$ifdef FPC_WINLIKEWIDESTRING}
  203. p:=NewWidestring(length(WideString(S)));
  204. move(s^,p^,length(WideString(s))*sizeof(widechar));
  205. s:=p;
  206. {$else FPC_WINLIKEWIDESTRING}
  207. { Let's be paranoid : Constant string ??}
  208. If PWideRec(S-WideFirstOff)^.Ref<0 then exit;
  209. inclocked(PWideRec(S-WideFirstOff)^.Ref);
  210. {$endif FPC_WINLIKEWIDESTRING}
  211. end;
  212. { alias for internal use }
  213. Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_INCR_REF'];
  214. function fpc_WideStr_To_ShortStr (high_of_res: SizeInt;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; compilerproc;
  215. {
  216. Converts a WideString to a ShortString;
  217. }
  218. Var
  219. Size : SizeInt;
  220. temp : ansistring;
  221. begin
  222. result:='';
  223. Size:=Length(S2);
  224. if Size>0 then
  225. begin
  226. If Size>high_of_res then
  227. Size:=high_of_res;
  228. widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
  229. result:=temp;
  230. end;
  231. end;
  232. Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString;compilerproc;
  233. {
  234. Converts a ShortString to a WideString;
  235. }
  236. Var
  237. Size : SizeInt;
  238. begin
  239. result:='';
  240. Size:=Length(S2);
  241. if Size>0 then
  242. begin
  243. widestringmanager.Ansi2WideMoveProc(PChar(@S2[1]),result,Size);
  244. { Terminating Zero }
  245. PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
  246. end;
  247. end;
  248. Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
  249. {
  250. Converts a WideString to an AnsiString
  251. }
  252. Var
  253. Size : SizeInt;
  254. begin
  255. result:='';
  256. Size:=Length(S2);
  257. if Size>0 then
  258. widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,Size);
  259. end;
  260. Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
  261. {
  262. Converts an AnsiString to a WideString;
  263. }
  264. Var
  265. Size : SizeInt;
  266. begin
  267. result:='';
  268. Size:=Length(S2);
  269. if Size>0 then
  270. widestringmanager.Ansi2WideMoveProc(PChar(S2),result,Size);
  271. end;
  272. Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
  273. var
  274. Size : SizeInt;
  275. begin
  276. result:='';
  277. if p=nil then
  278. exit;
  279. Size := IndexWord(p^, -1, 0);
  280. if Size>0 then
  281. widestringmanager.Wide2AnsiMoveProc(P,result,Size);
  282. end;
  283. Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
  284. var
  285. Size : SizeInt;
  286. begin
  287. result:='';
  288. if p=nil then
  289. exit;
  290. Size := IndexWord(p^, -1, 0);
  291. Setlength(result,Size);
  292. if Size>0 then
  293. begin
  294. Move(p^,PWideChar(Pointer(result))^,Size*sizeof(WideChar));
  295. { Terminating Zero }
  296. PWideChar(Pointer(result)+Size*sizeof(WideChar))^:=#0;
  297. end;
  298. end;
  299. Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
  300. var
  301. Size : SizeInt;
  302. temp: ansistring;
  303. begin
  304. result:='';
  305. if p=nil then
  306. exit;
  307. Size := IndexWord(p^, $7fffffff, 0);
  308. if Size>0 then
  309. begin
  310. widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
  311. result:=temp;
  312. end;
  313. end;
  314. { checked against the ansistring routine, 2001-05-27 (FK) }
  315. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; compilerproc;
  316. {
  317. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
  318. }
  319. begin
  320. {$ifdef FPC_WINLIKEWIDESTRING}
  321. { Decrease the reference count on the old S1 }
  322. fpc_widestr_decr_ref (S1);
  323. if S2<>nil then
  324. begin
  325. S1:=NewWidestring(length(WideString(S2)));
  326. move(s2^,s1^,length(WideString(s1))*sizeof(widechar));
  327. end
  328. else
  329. S1:=nil;
  330. {$else FPC_WINLIKEWIDESTRING}
  331. If S2<>nil then
  332. If PWideRec(S2-WideFirstOff)^.Ref>0 then
  333. inclocked(PWideRec(S2-WideFirstOff)^.ref);
  334. { Decrease the reference count on the old S1 }
  335. fpc_widestr_decr_ref (S1);
  336. s1:=s2;
  337. {$endif FPC_WINLIKEWIDESTRING}
  338. end;
  339. { alias for internal use }
  340. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
  341. {$ifndef STR_CONCAT_PROCS}
  342. function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
  343. Var
  344. Size,Location : SizeInt;
  345. pc : pwidechar;
  346. begin
  347. { only assign if s1 or s2 is empty }
  348. if (S1='') then
  349. begin
  350. result:=s2;
  351. exit;
  352. end;
  353. if (S2='') then
  354. begin
  355. result:=s1;
  356. exit;
  357. end;
  358. Location:=Length(S1);
  359. Size:=length(S2);
  360. SetLength(result,Size+Location);
  361. pc:=pwidechar(result);
  362. Move(S1[1],pc^,Location*sizeof(WideChar));
  363. inc(pc,location);
  364. Move(S2[1],pc^,(Size+1)*sizeof(WideChar));
  365. end;
  366. function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
  367. Var
  368. i : Longint;
  369. p : pointer;
  370. pc : pwidechar;
  371. Size,NewSize : SizeInt;
  372. begin
  373. { First calculate size of the result so we can do
  374. a single call to SetLength() }
  375. NewSize:=0;
  376. for i:=low(sarr) to high(sarr) do
  377. inc(Newsize,length(sarr[i]));
  378. SetLength(result,NewSize);
  379. pc:=pwidechar(result);
  380. for i:=low(sarr) to high(sarr) do
  381. begin
  382. p:=pointer(sarr[i]);
  383. if assigned(p) then
  384. begin
  385. Size:=length(widestring(p));
  386. Move(pwidechar(p)^,pc^,(Size+1)*sizeof(WideChar));
  387. inc(pc,size);
  388. end;
  389. end;
  390. end;
  391. {$else STR_CONCAT_PROCS}
  392. procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
  393. Var
  394. Size,Location : SizeInt;
  395. same : boolean;
  396. begin
  397. { only assign if s1 or s2 is empty }
  398. if (S1='') then
  399. begin
  400. DestS:=s2;
  401. exit;
  402. end;
  403. if (S2='') then
  404. begin
  405. DestS:=s1;
  406. exit;
  407. end;
  408. Location:=Length(S1);
  409. Size:=length(S2);
  410. { Use Pointer() typecasts to prevent extra conversion code }
  411. if Pointer(DestS)=Pointer(S1) then
  412. begin
  413. same:=Pointer(S1)=Pointer(S2);
  414. SetLength(DestS,Size+Location);
  415. if same then
  416. Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size)*sizeof(WideChar))
  417. else
  418. Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  419. end
  420. else if Pointer(DestS)=Pointer(S2) then
  421. begin
  422. SetLength(DestS,Size+Location);
  423. Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  424. Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
  425. end
  426. else
  427. begin
  428. DestS:='';
  429. SetLength(DestS,Size+Location);
  430. Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
  431. Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  432. end;
  433. end;
  434. procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
  435. Var
  436. lowstart,i : Longint;
  437. p,pc : pointer;
  438. Size,NewLen,
  439. OldDestLen : SizeInt;
  440. destcopy : widestring;
  441. begin
  442. if high(sarr)=0 then
  443. begin
  444. DestS:='';
  445. exit;
  446. end;
  447. lowstart:=low(sarr);
  448. if Pointer(DestS)=Pointer(sarr[lowstart]) then
  449. inc(lowstart);
  450. { Check for another reuse, then we can't use
  451. the append optimization }
  452. for i:=lowstart to high(sarr) do
  453. begin
  454. if Pointer(DestS)=Pointer(sarr[i]) then
  455. begin
  456. { if DestS is used somewhere in the middle of the expression,
  457. we need to make sure the original string still exists after
  458. we empty/modify DestS }
  459. destcopy:=dests;
  460. lowstart:=low(sarr);
  461. break;
  462. end;
  463. end;
  464. { Start with empty DestS if we start with concatting
  465. the first array element }
  466. if lowstart=low(sarr) then
  467. DestS:='';
  468. OldDestLen:=length(DestS);
  469. { Calculate size of the result so we can do
  470. a single call to SetLength() }
  471. NewLen:=0;
  472. for i:=low(sarr) to high(sarr) do
  473. inc(NewLen,length(sarr[i]));
  474. SetLength(DestS,NewLen);
  475. { Concat all strings, except the string we already
  476. copied in DestS }
  477. pc:=Pointer(DestS)+OldDestLen*sizeof(WideChar);
  478. for i:=lowstart to high(sarr) do
  479. begin
  480. p:=pointer(sarr[i]);
  481. if assigned(p) then
  482. begin
  483. Size:=length(widestring(p));
  484. Move(p^,pc^,(Size+1)*sizeof(WideChar));
  485. inc(pc,size*sizeof(WideChar));
  486. end;
  487. end;
  488. end;
  489. {$endif STR_CONCAT_PROCS}
  490. Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
  491. {
  492. Converts a Char to a WideString;
  493. }
  494. begin
  495. if c = #0 then
  496. { result is automatically set to '' }
  497. exit;
  498. Setlength(fpc_Char_To_WideStr,1);
  499. fpc_Char_To_WideStr[1]:=c;
  500. { Terminating Zero }
  501. PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
  502. end;
  503. Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
  504. Var
  505. L : SizeInt;
  506. begin
  507. if (not assigned(p)) or (p[0]=#0) Then
  508. { result is automatically set to '' }
  509. exit;
  510. l:=IndexChar(p^,-1,#0);
  511. widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
  512. end;
  513. Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
  514. var
  515. i : SizeInt;
  516. begin
  517. if (zerobased) then
  518. begin
  519. if (arr[0]=#0) Then
  520. { result is automatically set to '' }
  521. exit;
  522. i:=IndexChar(arr,high(arr)+1,#0);
  523. if i = -1 then
  524. i := high(arr)+1;
  525. end
  526. else
  527. i := high(arr)+1;
  528. SetLength(fpc_CharArray_To_WideStr,i);
  529. widestringmanager.Ansi2WideMoveProc (pchar(@arr),fpc_CharArray_To_WideStr,i);
  530. end;
  531. function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
  532. var
  533. l: longint;
  534. index: longint;
  535. len: byte;
  536. temp: ansistring;
  537. begin
  538. l := high(arr)+1;
  539. if l>=256 then
  540. l:=255
  541. else if l<0 then
  542. l:=0;
  543. if zerobased then
  544. begin
  545. index:=IndexWord(arr[0],l,0);
  546. if (index < 0) then
  547. len := l
  548. else
  549. len := index;
  550. end
  551. else
  552. len := l;
  553. widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
  554. fpc_WideCharArray_To_ShortStr := temp;
  555. end;
  556. Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
  557. var
  558. i : SizeInt;
  559. begin
  560. if (zerobased) then
  561. begin
  562. i:=IndexWord(arr,high(arr)+1,0);
  563. if i = -1 then
  564. i := high(arr)+1;
  565. end
  566. else
  567. i := high(arr)+1;
  568. SetLength(fpc_WideCharArray_To_AnsiStr,i);
  569. widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
  570. end;
  571. Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
  572. var
  573. i : SizeInt;
  574. begin
  575. if (zerobased) then
  576. begin
  577. i:=IndexWord(arr,high(arr)+1,0);
  578. if i = -1 then
  579. i := high(arr)+1;
  580. end
  581. else
  582. i := high(arr)+1;
  583. SetLength(fpc_WideCharArray_To_WideStr,i);
  584. Move(pwidechar(@arr)^, PWideChar(Pointer(@fpc_WideCharArray_To_WideStr[1]))^,i*sizeof(WideChar));
  585. { Terminating Zero }
  586. PWideChar(Pointer(@fpc_WideCharArray_To_WideStr[1])+i*sizeof(WideChar))^:=#0;
  587. end;
  588. { inside the compiler, the resulttype is modified to that of the actual }
  589. { chararray we're converting to (JM) }
  590. function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
  591. var
  592. len: SizeInt;
  593. temp: ansistring;
  594. begin
  595. len := length(src);
  596. { make sure we don't dereference src if it can be nil (JM) }
  597. if len > 0 then
  598. widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
  599. len := length(temp);
  600. if len > arraysize then
  601. len := arraysize;
  602. move(temp[1],fpc_widestr_to_chararray[0],len);
  603. fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
  604. end;
  605. { inside the compiler, the resulttype is modified to that of the actual }
  606. { widechararray we're converting to (JM) }
  607. function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray;[public,alias: 'FPC_WIDESTR_TO_WIDECHARARRAY']; compilerproc;
  608. var
  609. len: SizeInt;
  610. begin
  611. len := length(src);
  612. if len > arraysize then
  613. len := arraysize;
  614. { make sure we don't try to access element 1 of the ansistring if it's nil }
  615. if len > 0 then
  616. move(src[1],fpc_widestr_to_widechararray[0],len*SizeOf(WideChar));
  617. fillchar(fpc_widestr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  618. end;
  619. { inside the compiler, the resulttype is modified to that of the actual }
  620. { chararray we're converting to (JM) }
  621. function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray;[public,alias: 'FPC_ANSISTR_TO_WIDECHARARRAY']; compilerproc;
  622. var
  623. len: SizeInt;
  624. temp: widestring;
  625. begin
  626. len := length(src);
  627. { make sure we don't dereference src if it can be nil (JM) }
  628. if len > 0 then
  629. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  630. len := length(temp);
  631. if len > arraysize then
  632. len := arraysize;
  633. move(temp[1],fpc_ansistr_to_widechararray[0],len*sizeof(widechar));
  634. fillchar(fpc_ansistr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  635. end;
  636. function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray;[public,alias: 'FPC_SHORTSTR_TO_WIDECHARARRAY']; compilerproc;
  637. var
  638. len: longint;
  639. temp : widestring;
  640. begin
  641. len := length(src);
  642. { make sure we don't access char 1 if length is 0 (JM) }
  643. if len > 0 then
  644. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  645. len := length(temp);
  646. if len > arraysize then
  647. len := arraysize;
  648. move(temp[1],fpc_shortstr_to_widechararray[0],len*sizeof(widechar));
  649. fillchar(fpc_shortstr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  650. end;
  651. Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE']; compilerproc;
  652. {
  653. Compares 2 WideStrings;
  654. The result is
  655. <0 if S1<S2
  656. 0 if S1=S2
  657. >0 if S1>S2
  658. }
  659. Var
  660. MaxI,Temp : SizeInt;
  661. begin
  662. if pointer(S1)=pointer(S2) then
  663. begin
  664. fpc_WideStr_Compare:=0;
  665. exit;
  666. end;
  667. Maxi:=Length(S1);
  668. temp:=Length(S2);
  669. If MaxI>Temp then
  670. MaxI:=Temp;
  671. Temp:=CompareWord(S1[1],S2[1],MaxI);
  672. if temp=0 then
  673. temp:=Length(S1)-Length(S2);
  674. fpc_WideStr_Compare:=Temp;
  675. end;
  676. Function fpc_WideStr_Compare_Equal(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE_EQUAL']; compilerproc;
  677. {
  678. Compares 2 WideStrings for equality only;
  679. The result is
  680. 0 if S1=S2
  681. <>0 if S1<>S2
  682. }
  683. Var
  684. MaxI : SizeInt;
  685. begin
  686. if pointer(S1)=pointer(S2) then
  687. exit(0);
  688. Maxi:=Length(S1);
  689. If MaxI<>Length(S2) then
  690. exit(-1)
  691. else
  692. exit(CompareWord(S1[1],S2[1],MaxI));
  693. end;
  694. Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
  695. begin
  696. if p=nil then
  697. HandleErrorFrame(201,get_frame);
  698. end;
  699. Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
  700. begin
  701. if (index>len) or (Index<1) then
  702. HandleErrorFrame(201,get_frame);
  703. end;
  704. Procedure fpc_WideStr_SetLength(Var S : WideString; l : SizeInt);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; compilerproc;
  705. {
  706. Sets The length of string S to L.
  707. Makes sure S is unique, and contains enough room.
  708. }
  709. Var
  710. Temp : Pointer;
  711. movelen: SizeInt;
  712. begin
  713. if (l>0) then
  714. begin
  715. if Pointer(S)=nil then
  716. begin
  717. { Need a complete new string...}
  718. Pointer(s):=NewWideString(l);
  719. end
  720. { windows doesn't support reallocing widestrings, this code
  721. is anyways subject to be removed because widestrings shouldn't be
  722. ref. counted anymore (FK) }
  723. else
  724. {$ifndef FPC_WINLIKEWIDESTRING}
  725. if
  726. {$ifdef MSWINDOWS}
  727. not winwidestringalloc and
  728. {$endif MSWINDOWS}
  729. (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
  730. begin
  731. Dec(Pointer(S),WideFirstOff);
  732. if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
  733. reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
  734. Inc(Pointer(S), WideFirstOff);
  735. end
  736. else
  737. {$endif FPC_WINLIKEWIDESTRING}
  738. begin
  739. { Reallocation is needed... }
  740. Temp:=Pointer(NewWideString(L));
  741. if Length(S)>0 then
  742. begin
  743. if l < succ(length(s)) then
  744. movelen := l
  745. { also move terminating null }
  746. else
  747. movelen := succ(length(s));
  748. Move(Pointer(S)^,Temp^,movelen * Sizeof(WideChar));
  749. end;
  750. fpc_widestr_decr_ref(Pointer(S));
  751. Pointer(S):=Temp;
  752. end;
  753. { Force nil termination in case it gets shorter }
  754. PWord(Pointer(S)+l*sizeof(WideChar))^:=0;
  755. {$ifndef FPC_WINLIKEWIDESTRING}
  756. PWideRec(Pointer(S)-WideFirstOff)^.Len:=l*sizeof(WideChar);
  757. {$endif FPC_WINLIKEWIDESTRING}
  758. end
  759. else
  760. begin
  761. { Length=0 }
  762. if Pointer(S)<>nil then
  763. fpc_widestr_decr_ref (Pointer(S));
  764. Pointer(S):=Nil;
  765. end;
  766. end;
  767. {*****************************************************************************
  768. Public functions, In interface.
  769. *****************************************************************************}
  770. function WideCharToString(S : PWideChar) : AnsiString;
  771. begin
  772. result:=WideCharLenToString(s,Length(WideString(s)));
  773. end;
  774. function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
  775. var
  776. temp:widestring;
  777. begin
  778. widestringmanager.Ansi2WideMoveProc(PChar(Src),temp,Length(Src));
  779. if Length(temp)<DestSize then
  780. move(temp[1],Dest^,Length(temp)*SizeOf(WideChar))
  781. else
  782. move(temp[1],Dest^,(DestSize-1)*SizeOf(WideChar));
  783. Dest[DestSize-1]:=#0;
  784. result:=Dest;
  785. end;
  786. function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
  787. begin
  788. //SetLength(result,Len);
  789. widestringmanager.Wide2AnsiMoveproc(S,result,Len);
  790. end;
  791. procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
  792. begin
  793. Dest:=WideCharLenToString(Src,Len);
  794. end;
  795. procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
  796. begin
  797. Dest:=WideCharToString(S);
  798. end;
  799. Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
  800. {$ifdef FPC_WINLIKEWIDESTRING}
  801. begin
  802. pointer(result) := pointer(s);
  803. end;
  804. {$else FPC_WINLIKEWIDESTRING}
  805. {
  806. Make sure reference count of S is 1,
  807. using copy-on-write semantics.
  808. }
  809. Var
  810. SNew : Pointer;
  811. L : SizeInt;
  812. begin
  813. pointer(result) := pointer(s);
  814. If Pointer(S)=Nil then
  815. exit;
  816. if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
  817. begin
  818. L:=PWideRec(Pointer(S)-WideFirstOff)^.len div sizeof(WideChar);
  819. SNew:=NewWideString (L);
  820. Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
  821. PWideRec(SNew-WideFirstOff)^.len:=L * sizeof(WideChar);
  822. fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
  823. pointer(S):=SNew;
  824. pointer(result):=SNew;
  825. end;
  826. end;
  827. {$endif FPC_WINLIKEWIDESTRING}
  828. Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
  829. var
  830. ResultAddress : Pointer;
  831. begin
  832. ResultAddress:=Nil;
  833. dec(index);
  834. if Index < 0 then
  835. Index := 0;
  836. { Check Size. Accounts for Zero-length S, the double check is needed because
  837. Size can be maxint and will get <0 when adding index }
  838. if (Size>Length(S)) or
  839. (Index+Size>Length(S)) then
  840. Size:=Length(S)-Index;
  841. If Size>0 then
  842. begin
  843. If Index<0 Then
  844. Index:=0;
  845. ResultAddress:=Pointer(NewWideString (Size));
  846. if ResultAddress<>Nil then
  847. begin
  848. Move (PWideChar(S)[Index],ResultAddress^,Size*sizeof(WideChar));
  849. PWideRec(ResultAddress-WideFirstOff)^.Len:=Size*sizeof(WideChar);
  850. PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
  851. end;
  852. end;
  853. Pointer(fpc_widestr_Copy):=ResultAddress;
  854. end;
  855. Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
  856. var
  857. i,MaxLen : SizeInt;
  858. pc : pwidechar;
  859. begin
  860. Pos:=0;
  861. if Length(SubStr)>0 then
  862. begin
  863. MaxLen:=Length(source)-Length(SubStr);
  864. i:=0;
  865. pc:=@source[1];
  866. while (i<=MaxLen) do
  867. begin
  868. inc(i);
  869. if (SubStr[1]=pc^) and
  870. (CompareWord(Substr[1],pc^,Length(SubStr))=0) then
  871. begin
  872. Pos:=i;
  873. exit;
  874. end;
  875. inc(pc);
  876. end;
  877. end;
  878. end;
  879. { Faster version for a widechar alone }
  880. Function Pos (c : WideChar; Const s : WideString) : SizeInt;
  881. var
  882. i: SizeInt;
  883. pc : pwidechar;
  884. begin
  885. pc:=@s[1];
  886. for i:=1 to length(s) do
  887. begin
  888. if pc^=c then
  889. begin
  890. pos:=i;
  891. exit;
  892. end;
  893. inc(pc);
  894. end;
  895. pos:=0;
  896. end;
  897. Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
  898. var
  899. i: SizeInt;
  900. pc : pchar;
  901. begin
  902. pc:=@s[1];
  903. for i:=1 to length(s) do
  904. begin
  905. if widechar(pc^)=c then
  906. begin
  907. pos:=i;
  908. exit;
  909. end;
  910. inc(pc);
  911. end;
  912. pos:=0;
  913. end;
  914. Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  915. begin
  916. result:=Pos(WideString(c),s);
  917. end;
  918. Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  919. begin
  920. result:=Pos(WideString(c),s);
  921. end;
  922. Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  923. begin
  924. result:=Pos(c,WideString(s));
  925. end;
  926. { Faster version for a char alone. Must be implemented because }
  927. { pos(c: char; const s: shortstring) also exists, so otherwise }
  928. { using pos(char,pchar) will always call the shortstring version }
  929. { (exact match for first argument), also with $h+ (JM) }
  930. Function Pos (c : Char; Const s : WideString) : SizeInt;
  931. var
  932. i: SizeInt;
  933. wc : widechar;
  934. pc : pwidechar;
  935. begin
  936. wc:=c;
  937. pc:=@s[1];
  938. for i:=1 to length(s) do
  939. begin
  940. if pc^=wc then
  941. begin
  942. pos:=i;
  943. exit;
  944. end;
  945. inc(pc);
  946. end;
  947. pos:=0;
  948. end;
  949. Procedure Delete (Var S : WideString; Index,Size: SizeInt);
  950. Var
  951. LS : SizeInt;
  952. begin
  953. If Length(S)=0 then
  954. exit;
  955. if index<=0 then
  956. exit;
  957. LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len div sizeof(WideChar);
  958. if (Index<=LS) and (Size>0) then
  959. begin
  960. UniqueString (S);
  961. if Size+Index>LS then
  962. Size:=LS-Index+1;
  963. if Index+Size<=LS then
  964. begin
  965. Dec(Index);
  966. Move(PWideChar(S)[Index+Size],PWideChar(S)[Index],(LS-Index+1)*sizeof(WideChar));
  967. end;
  968. Setlength(s,LS-Size);
  969. end;
  970. end;
  971. Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
  972. var
  973. Temp : WideString;
  974. LS : SizeInt;
  975. begin
  976. If Length(Source)=0 then
  977. exit;
  978. if index <= 0 then
  979. index := 1;
  980. Ls:=Length(S);
  981. if index > LS then
  982. index := LS+1;
  983. Dec(Index);
  984. Pointer(Temp) := NewWideString(Length(Source)+LS);
  985. SetLength(Temp,Length(Source)+LS);
  986. If Index>0 then
  987. move (PWideChar(S)^,PWideChar(Temp)^,Index*sizeof(WideChar));
  988. Move (PWideChar(Source)^,PWideChar(Temp)[Index],Length(Source)*sizeof(WideChar));
  989. If (LS-Index)>0 then
  990. Move(PWideChar(S)[Index],PWideChar(temp)[Length(Source)+index],(LS-Index)*sizeof(WideChar));
  991. S:=Temp;
  992. end;
  993. function UpCase(const s : WideString) : WideString;
  994. begin
  995. result:=widestringmanager.UpperWideStringProc(s);
  996. end;
  997. Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
  998. var
  999. BufLen: SizeInt;
  1000. begin
  1001. SetLength(S,Len);
  1002. If (Buf<>Nil) and (Len>0) then
  1003. begin
  1004. BufLen := IndexWord(Buf^, Len+1, 0);
  1005. If (BufLen>0) and (BufLen < Len) then
  1006. Len := BufLen;
  1007. Move (Buf[0],S[1],Len*sizeof(WideChar));
  1008. PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
  1009. end;
  1010. end;
  1011. Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
  1012. var
  1013. BufLen: SizeInt;
  1014. begin
  1015. SetLength(S,Len);
  1016. If (Buf<>Nil) and (Len>0) then
  1017. begin
  1018. BufLen := IndexByte(Buf^, Len+1, 0);
  1019. If (BufLen>0) and (BufLen < Len) then
  1020. Len := BufLen;
  1021. widestringmanager.Ansi2WideMoveProc(Buf,S,Len);
  1022. //PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
  1023. end;
  1024. end;
  1025. Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; compilerproc;
  1026. Var
  1027. SS : String;
  1028. begin
  1029. fpc_Val_Real_WideStr := 0;
  1030. if length(S) > 255 then
  1031. code := 256
  1032. else
  1033. begin
  1034. SS := S;
  1035. Val(SS,fpc_Val_Real_WideStr,code);
  1036. end;
  1037. end;
  1038. Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
  1039. Var
  1040. SS : String;
  1041. begin
  1042. if length(S) > 255 then
  1043. begin
  1044. fpc_Val_Currency_WideStr:=0;
  1045. code := 256;
  1046. end
  1047. else
  1048. begin
  1049. SS := S;
  1050. Val(SS,fpc_Val_Currency_WideStr,code);
  1051. end;
  1052. end;
  1053. Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; compilerproc;
  1054. Var
  1055. SS : ShortString;
  1056. begin
  1057. fpc_Val_UInt_WideStr := 0;
  1058. if length(S) > 255 then
  1059. code := 256
  1060. else
  1061. begin
  1062. SS := S;
  1063. Val(SS,fpc_Val_UInt_WideStr,code);
  1064. end;
  1065. end;
  1066. Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; compilerproc;
  1067. Var
  1068. SS : ShortString;
  1069. begin
  1070. fpc_Val_SInt_WideStr:=0;
  1071. if length(S)>255 then
  1072. code:=256
  1073. else
  1074. begin
  1075. SS := S;
  1076. fpc_Val_SInt_WideStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
  1077. end;
  1078. end;
  1079. {$ifndef CPU64}
  1080. Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; compilerproc;
  1081. Var
  1082. SS : ShortString;
  1083. begin
  1084. fpc_Val_qword_WideStr:=0;
  1085. if length(S)>255 then
  1086. code:=256
  1087. else
  1088. begin
  1089. SS := S;
  1090. Val(SS,fpc_Val_qword_WideStr,Code);
  1091. end;
  1092. end;
  1093. Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; compilerproc;
  1094. Var
  1095. SS : ShortString;
  1096. begin
  1097. fpc_Val_int64_WideStr:=0;
  1098. if length(S)>255 then
  1099. code:=256
  1100. else
  1101. begin
  1102. SS := S;
  1103. Val(SS,fpc_Val_int64_WideStr,Code);
  1104. end;
  1105. end;
  1106. {$endif CPU64}
  1107. procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString);compilerproc;
  1108. var
  1109. ss : shortstring;
  1110. begin
  1111. str_real(len,fr,d,treal_type(rt),ss);
  1112. s:=ss;
  1113. end;
  1114. {$ifdef FPC_HAS_STR_CURRENCY}
  1115. procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
  1116. var
  1117. ss : shortstring;
  1118. begin
  1119. str(c:len:fr,ss);
  1120. s:=ss;
  1121. end;
  1122. {$endif FPC_HAS_STR_CURRENCY}
  1123. Procedure fpc_WideStr_SInt(v : ValSint; Len : SizeInt; out S : WideString);compilerproc;
  1124. Var
  1125. SS : ShortString;
  1126. begin
  1127. Str (v:Len,SS);
  1128. S:=SS;
  1129. end;
  1130. Procedure fpc_WideStr_UInt(v : ValUInt;Len : SizeInt; out S : WideString);compilerproc;
  1131. Var
  1132. SS : ShortString;
  1133. begin
  1134. str(v:Len,SS);
  1135. S:=SS;
  1136. end;
  1137. {$ifndef CPU64}
  1138. Procedure fpc_WideStr_Int64(v : Int64; Len : SizeInt; out S : WideString);compilerproc;
  1139. Var
  1140. SS : ShortString;
  1141. begin
  1142. Str (v:Len,SS);
  1143. S:=SS;
  1144. end;
  1145. Procedure fpc_WideStr_Qword(v : Qword;Len : SizeInt; out S : WideString);compilerproc;
  1146. Var
  1147. SS : ShortString;
  1148. begin
  1149. str(v:Len,SS);
  1150. S:=SS;
  1151. end;
  1152. {$endif CPU64}
  1153. function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1154. begin
  1155. if assigned(Source) then
  1156. Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
  1157. else
  1158. Result:=0;
  1159. end;
  1160. function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
  1161. var
  1162. i,j : SizeUInt;
  1163. w : word;
  1164. begin
  1165. result:=0;
  1166. if source=nil then
  1167. exit;
  1168. i:=0;
  1169. j:=0;
  1170. if assigned(Dest) then
  1171. begin
  1172. while (i<SourceChars) and (j<MaxDestBytes) do
  1173. begin
  1174. w:=word(Source[i]);
  1175. case w of
  1176. 0..$7f:
  1177. begin
  1178. Dest[j]:=char(w);
  1179. inc(j);
  1180. end;
  1181. $80..$7ff:
  1182. begin
  1183. if j+1>=MaxDestBytes then
  1184. break;
  1185. Dest[j]:=char($c0 or (w shr 6));
  1186. Dest[j+1]:=char($80 or (w and $3f));
  1187. inc(j,2);
  1188. end;
  1189. else
  1190. begin
  1191. if j+2>=MaxDestBytes then
  1192. break;
  1193. Dest[j]:=char($e0 or (w shr 12));
  1194. Dest[j+1]:=char($80 or ((w shr 6)and $3f));
  1195. Dest[j+2]:=char($80 or (w and $3f));
  1196. inc(j,3);
  1197. end;
  1198. end;
  1199. inc(i);
  1200. end;
  1201. if j>MaxDestBytes-1 then
  1202. j:=MaxDestBytes-1;
  1203. Dest[j]:=#0;
  1204. end
  1205. else
  1206. begin
  1207. while i<SourceChars do
  1208. begin
  1209. case word(Source[i]) of
  1210. $0..$7f:
  1211. inc(j);
  1212. $80..$7ff:
  1213. inc(j,2);
  1214. else
  1215. inc(j,3);
  1216. end;
  1217. end;
  1218. end;
  1219. result:=j+1;
  1220. end;
  1221. function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1222. begin
  1223. if assigned(Source) then
  1224. Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
  1225. else
  1226. Result:=0;
  1227. end;
  1228. function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
  1229. var
  1230. i,j : SizeUInt;
  1231. w: SizeUInt;
  1232. b : byte;
  1233. begin
  1234. if not assigned(Source) then
  1235. begin
  1236. result:=0;
  1237. exit;
  1238. end;
  1239. result:=SizeUInt(-1);
  1240. i:=0;
  1241. j:=0;
  1242. if assigned(Dest) then
  1243. begin
  1244. while (j<MaxDestChars) and (i<SourceBytes) do
  1245. begin
  1246. b:=byte(Source[i]);
  1247. w:=b;
  1248. inc(i);
  1249. // 2 or 3 bytes?
  1250. if b>=$80 then
  1251. begin
  1252. w:=b and $3f;
  1253. if i>=SourceBytes then
  1254. exit;
  1255. // 3 bytes?
  1256. if (b and $20)<>0 then
  1257. begin
  1258. b:=byte(Source[i]);
  1259. inc(i);
  1260. if i>=SourceBytes then
  1261. exit;
  1262. if (b and $c0)<>$80 then
  1263. exit;
  1264. w:=(w shl 6) or (b and $3f);
  1265. end;
  1266. b:=byte(Source[i]);
  1267. w:=(w shl 6) or (b and $3f);
  1268. if (b and $c0)<>$80 then
  1269. exit;
  1270. inc(i);
  1271. end;
  1272. Dest[j]:=WideChar(w);
  1273. inc(j);
  1274. end;
  1275. if j>=MaxDestChars then j:=MaxDestChars-1;
  1276. Dest[j]:=#0;
  1277. end
  1278. else
  1279. begin
  1280. while i<SourceBytes do
  1281. begin
  1282. b:=byte(Source[i]);
  1283. inc(i);
  1284. // 2 or 3 bytes?
  1285. if b>=$80 then
  1286. begin
  1287. if i>=SourceBytes then
  1288. exit;
  1289. // 3 bytes?
  1290. b := b and $3f;
  1291. if (b and $20)<>0 then
  1292. begin
  1293. b:=byte(Source[i]);
  1294. inc(i);
  1295. if i>=SourceBytes then
  1296. exit;
  1297. if (b and $c0)<>$80 then
  1298. exit;
  1299. end;
  1300. if (byte(Source[i]) and $c0)<>$80 then
  1301. exit;
  1302. inc(i);
  1303. end;
  1304. inc(j);
  1305. end;
  1306. end;
  1307. result:=j+1;
  1308. end;
  1309. function UTF8Encode(const s : WideString) : UTF8String;
  1310. var
  1311. i : SizeInt;
  1312. hs : UTF8String;
  1313. begin
  1314. result:='';
  1315. if s='' then
  1316. exit;
  1317. SetLength(hs,length(s)*3);
  1318. i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PWideChar(s),length(s));
  1319. if i>0 then
  1320. begin
  1321. SetLength(hs,i-1);
  1322. result:=hs;
  1323. end;
  1324. end;
  1325. function UTF8Decode(const s : UTF8String): WideString;
  1326. var
  1327. i : SizeInt;
  1328. hs : WideString;
  1329. begin
  1330. result:='';
  1331. if s='' then
  1332. exit;
  1333. SetLength(hs,length(s));
  1334. i:=Utf8ToUnicode(PWideChar(hs),length(hs)+1,pchar(s),length(s));
  1335. if i>0 then
  1336. begin
  1337. SetLength(hs,i-1);
  1338. result:=hs;
  1339. end;
  1340. end;
  1341. function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
  1342. begin
  1343. Result:=Utf8Encode(s);
  1344. end;
  1345. function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
  1346. begin
  1347. Result:=Utf8Decode(s);
  1348. end;
  1349. function WideStringToUCS4String(const s : WideString) : UCS4String;
  1350. var
  1351. i : SizeInt;
  1352. begin
  1353. setlength(result,length(s)+1);
  1354. for i:=1 to length(s) do
  1355. result[i-1]:=UCS4Char(s[i]);
  1356. result[length(s)]:=UCS4Char(0);
  1357. end;
  1358. function UCS4StringToWideString(const s : UCS4String) : WideString;
  1359. var
  1360. i : SizeInt;
  1361. begin
  1362. setlength(result,length(s)-1);
  1363. for i:=1 to length(s)-1 do
  1364. result[i]:=WideChar(s[i-1]);
  1365. end;
  1366. procedure unimplementedwidestring;
  1367. begin
  1368. HandleErrorFrame(215,get_frame);
  1369. end;
  1370. {$warnings off}
  1371. function GenericWideCase(const s : WideString) : WideString;
  1372. begin
  1373. unimplementedwidestring;
  1374. end;
  1375. function CompareWideString(const s1, s2 : WideString) : PtrInt;
  1376. begin
  1377. unimplementedwidestring;
  1378. end;
  1379. function CompareTextWideString(const s1, s2 : WideString): PtrInt;
  1380. begin
  1381. unimplementedwidestring;
  1382. end;
  1383. function CharLengthPChar(const Str: PChar): PtrInt;
  1384. begin
  1385. unimplementedwidestring;
  1386. end;
  1387. {$warnings on}
  1388. procedure initwidestringmanager;
  1389. begin
  1390. fillchar(widestringmanager,sizeof(widestringmanager),0);
  1391. {$ifndef HAS_WIDESTRINGMANAGER}
  1392. widestringmanager.Wide2AnsiMoveProc:=@defaultWide2AnsiMove;
  1393. widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2WideMove;
  1394. widestringmanager.UpperWideStringProc:=@GenericWideCase;
  1395. widestringmanager.LowerWideStringProc:=@GenericWideCase;
  1396. {$endif HAS_WIDESTRINGMANAGER}
  1397. widestringmanager.CompareWideStringProc:=@CompareWideString;
  1398. widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
  1399. widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
  1400. end;