wstrings.inc 40 KB

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