wstrings.inc 41 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708
  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))+1)*sizeof(widechar)); // double #0 too
  205. s:=p;
  206. {$else FPC_WINLIKEWIDESTRING}
  207. { Let's be paranoid : Constant string ??}
  208. If PWideRec(S-WideFirstOff)^.Ref<0 then
  209. exit;
  210. inclocked(PWideRec(S-WideFirstOff)^.Ref);
  211. {$endif FPC_WINLIKEWIDESTRING}
  212. end;
  213. { alias for internal use }
  214. Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);[external name 'FPC_WIDESTR_INCR_REF'];
  215. function fpc_WideStr_To_ShortStr (high_of_res: SizeInt;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; compilerproc;
  216. {
  217. Converts a WideString to a ShortString;
  218. }
  219. Var
  220. Size : SizeInt;
  221. temp : ansistring;
  222. begin
  223. result:='';
  224. Size:=Length(S2);
  225. if Size>0 then
  226. begin
  227. If Size>high_of_res then
  228. Size:=high_of_res;
  229. widestringmanager.Wide2AnsiMoveProc(PWideChar(S2),temp,Size);
  230. result:=temp;
  231. end;
  232. end;
  233. Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString;compilerproc;
  234. {
  235. Converts a ShortString to a WideString;
  236. }
  237. Var
  238. Size : SizeInt;
  239. begin
  240. result:='';
  241. Size:=Length(S2);
  242. if Size>0 then
  243. begin
  244. widestringmanager.Ansi2WideMoveProc(PChar(@S2[1]),result,Size);
  245. { Terminating Zero }
  246. PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
  247. end;
  248. end;
  249. Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; compilerproc;
  250. {
  251. Converts a WideString to an AnsiString
  252. }
  253. Var
  254. Size : SizeInt;
  255. begin
  256. result:='';
  257. Size:=Length(S2);
  258. if Size>0 then
  259. widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,Size);
  260. end;
  261. Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; compilerproc;
  262. {
  263. Converts an AnsiString to a WideString;
  264. }
  265. Var
  266. Size : SizeInt;
  267. begin
  268. result:='';
  269. Size:=Length(S2);
  270. if Size>0 then
  271. widestringmanager.Ansi2WideMoveProc(PChar(S2),result,Size);
  272. end;
  273. Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
  274. var
  275. Size : SizeInt;
  276. begin
  277. result:='';
  278. if p=nil then
  279. exit;
  280. Size := IndexWord(p^, -1, 0);
  281. if Size>0 then
  282. widestringmanager.Wide2AnsiMoveProc(P,result,Size);
  283. end;
  284. Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
  285. var
  286. Size : SizeInt;
  287. begin
  288. result:='';
  289. if p=nil then
  290. exit;
  291. Size := IndexWord(p^, -1, 0);
  292. Setlength(result,Size);
  293. if Size>0 then
  294. begin
  295. Move(p^,PWideChar(Pointer(result))^,Size*sizeof(WideChar));
  296. { Terminating Zero }
  297. PWideChar(Pointer(result)+Size*sizeof(WideChar))^:=#0;
  298. end;
  299. end;
  300. Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
  301. var
  302. Size : SizeInt;
  303. temp: ansistring;
  304. begin
  305. result:='';
  306. if p=nil then
  307. exit;
  308. Size := IndexWord(p^, $7fffffff, 0);
  309. if Size>0 then
  310. begin
  311. widestringmanager.Wide2AnsiMoveProc(p,temp,Size);
  312. result:=temp;
  313. end;
  314. end;
  315. { checked against the ansistring routine, 2001-05-27 (FK) }
  316. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; compilerproc;
  317. {
  318. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
  319. }
  320. begin
  321. {$ifdef FPC_WINLIKEWIDESTRING}
  322. { Decrease the reference count on the old S1 }
  323. fpc_widestr_decr_ref (S1);
  324. if S2<>nil then
  325. begin
  326. S1:=NewWidestring(length(WideString(S2)));
  327. move(s2^,s1^,(length(WideString(s1))+1)*sizeof(widechar));
  328. end
  329. else
  330. S1:=nil;
  331. {$else FPC_WINLIKEWIDESTRING}
  332. If S2<>nil then
  333. If PWideRec(S2-WideFirstOff)^.Ref>0 then
  334. inclocked(PWideRec(S2-WideFirstOff)^.ref);
  335. { Decrease the reference count on the old S1 }
  336. fpc_widestr_decr_ref (S1);
  337. s1:=s2;
  338. {$endif FPC_WINLIKEWIDESTRING}
  339. end;
  340. { alias for internal use }
  341. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
  342. {$ifndef STR_CONCAT_PROCS}
  343. function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
  344. Var
  345. Size,Location : SizeInt;
  346. pc : pwidechar;
  347. begin
  348. { only assign if s1 or s2 is empty }
  349. if (S1='') then
  350. begin
  351. result:=s2;
  352. exit;
  353. end;
  354. if (S2='') then
  355. begin
  356. result:=s1;
  357. exit;
  358. end;
  359. Location:=Length(S1);
  360. Size:=length(S2);
  361. SetLength(result,Size+Location);
  362. pc:=pwidechar(result);
  363. Move(S1[1],pc^,Location*sizeof(WideChar));
  364. inc(pc,location);
  365. Move(S2[1],pc^,(Size+1)*sizeof(WideChar));
  366. end;
  367. function fpc_WideStr_Concat_multi (const sarr:array of Widestring): widestring; compilerproc;
  368. Var
  369. i : Longint;
  370. p : pointer;
  371. pc : pwidechar;
  372. Size,NewSize : SizeInt;
  373. begin
  374. { First calculate size of the result so we can do
  375. a single call to SetLength() }
  376. NewSize:=0;
  377. for i:=low(sarr) to high(sarr) do
  378. inc(Newsize,length(sarr[i]));
  379. SetLength(result,NewSize);
  380. pc:=pwidechar(result);
  381. for i:=low(sarr) to high(sarr) do
  382. begin
  383. p:=pointer(sarr[i]);
  384. if assigned(p) then
  385. begin
  386. Size:=length(widestring(p));
  387. Move(pwidechar(p)^,pc^,(Size+1)*sizeof(WideChar));
  388. inc(pc,size);
  389. end;
  390. end;
  391. end;
  392. {$else STR_CONCAT_PROCS}
  393. procedure fpc_WideStr_Concat (var DestS:Widestring;const S1,S2 : WideString); compilerproc;
  394. Var
  395. Size,Location : SizeInt;
  396. same : boolean;
  397. begin
  398. { only assign if s1 or s2 is empty }
  399. if (S1='') then
  400. begin
  401. DestS:=s2;
  402. exit;
  403. end;
  404. if (S2='') then
  405. begin
  406. DestS:=s1;
  407. exit;
  408. end;
  409. Location:=Length(S1);
  410. Size:=length(S2);
  411. { Use Pointer() typecasts to prevent extra conversion code }
  412. if Pointer(DestS)=Pointer(S1) then
  413. begin
  414. same:=Pointer(S1)=Pointer(S2);
  415. SetLength(DestS,Size+Location);
  416. if same then
  417. Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size)*sizeof(WideChar))
  418. else
  419. Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  420. end
  421. else if Pointer(DestS)=Pointer(S2) then
  422. begin
  423. SetLength(DestS,Size+Location);
  424. Move(Pointer(DestS)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  425. Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
  426. end
  427. else
  428. begin
  429. DestS:='';
  430. SetLength(DestS,Size+Location);
  431. Move(Pointer(S1)^,Pointer(DestS)^,Location*sizeof(WideChar));
  432. Move(Pointer(S2)^,(Pointer(DestS)+Location*sizeof(WideChar))^,(Size+1)*sizeof(WideChar));
  433. end;
  434. end;
  435. procedure fpc_WideStr_Concat_multi (var DestS:Widestring;const sarr:array of Widestring); compilerproc;
  436. Var
  437. lowstart,i : Longint;
  438. p,pc : pointer;
  439. Size,NewLen,
  440. OldDestLen : SizeInt;
  441. destcopy : widestring;
  442. begin
  443. if high(sarr)=0 then
  444. begin
  445. DestS:='';
  446. exit;
  447. end;
  448. lowstart:=low(sarr);
  449. if Pointer(DestS)=Pointer(sarr[lowstart]) then
  450. inc(lowstart);
  451. { Check for another reuse, then we can't use
  452. the append optimization }
  453. for i:=lowstart to high(sarr) do
  454. begin
  455. if Pointer(DestS)=Pointer(sarr[i]) then
  456. begin
  457. { if DestS is used somewhere in the middle of the expression,
  458. we need to make sure the original string still exists after
  459. we empty/modify DestS }
  460. destcopy:=dests;
  461. lowstart:=low(sarr);
  462. break;
  463. end;
  464. end;
  465. { Start with empty DestS if we start with concatting
  466. the first array element }
  467. if lowstart=low(sarr) then
  468. DestS:='';
  469. OldDestLen:=length(DestS);
  470. { Calculate size of the result so we can do
  471. a single call to SetLength() }
  472. NewLen:=0;
  473. for i:=low(sarr) to high(sarr) do
  474. inc(NewLen,length(sarr[i]));
  475. SetLength(DestS,NewLen);
  476. { Concat all strings, except the string we already
  477. copied in DestS }
  478. pc:=Pointer(DestS)+OldDestLen*sizeof(WideChar);
  479. for i:=lowstart to high(sarr) do
  480. begin
  481. p:=pointer(sarr[i]);
  482. if assigned(p) then
  483. begin
  484. Size:=length(widestring(p));
  485. Move(p^,pc^,(Size+1)*sizeof(WideChar));
  486. inc(pc,size*sizeof(WideChar));
  487. end;
  488. end;
  489. end;
  490. {$endif STR_CONCAT_PROCS}
  491. Function fpc_Char_To_WideStr(const c : WideChar): WideString; compilerproc;
  492. {
  493. Converts a Char to a WideString;
  494. }
  495. begin
  496. if c = #0 then
  497. { result is automatically set to '' }
  498. exit;
  499. Setlength(fpc_Char_To_WideStr,1);
  500. fpc_Char_To_WideStr[1]:=c;
  501. { Terminating Zero }
  502. PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
  503. end;
  504. Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
  505. Var
  506. L : SizeInt;
  507. begin
  508. if (not assigned(p)) or (p[0]=#0) Then
  509. { result is automatically set to '' }
  510. exit;
  511. l:=IndexChar(p^,-1,#0);
  512. widestringmanager.Ansi2WideMoveProc(P,fpc_PChar_To_WideStr,l);
  513. end;
  514. Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
  515. var
  516. i : SizeInt;
  517. begin
  518. if (zerobased) then
  519. begin
  520. if (arr[0]=#0) Then
  521. { result is automatically set to '' }
  522. exit;
  523. i:=IndexChar(arr,high(arr)+1,#0);
  524. if i = -1 then
  525. i := high(arr)+1;
  526. end
  527. else
  528. i := high(arr)+1;
  529. SetLength(fpc_CharArray_To_WideStr,i);
  530. widestringmanager.Ansi2WideMoveProc (pchar(@arr),fpc_CharArray_To_WideStr,i);
  531. end;
  532. function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
  533. var
  534. l: longint;
  535. index: longint;
  536. len: byte;
  537. temp: ansistring;
  538. begin
  539. l := high(arr)+1;
  540. if l>=256 then
  541. l:=255
  542. else if l<0 then
  543. l:=0;
  544. if zerobased then
  545. begin
  546. index:=IndexWord(arr[0],l,0);
  547. if (index < 0) then
  548. len := l
  549. else
  550. len := index;
  551. end
  552. else
  553. len := l;
  554. widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
  555. fpc_WideCharArray_To_ShortStr := temp;
  556. end;
  557. Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
  558. var
  559. i : SizeInt;
  560. begin
  561. if (zerobased) then
  562. begin
  563. i:=IndexWord(arr,high(arr)+1,0);
  564. if i = -1 then
  565. i := high(arr)+1;
  566. end
  567. else
  568. i := high(arr)+1;
  569. SetLength(fpc_WideCharArray_To_AnsiStr,i);
  570. widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
  571. end;
  572. Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
  573. var
  574. i : SizeInt;
  575. begin
  576. if (zerobased) then
  577. begin
  578. i:=IndexWord(arr,high(arr)+1,0);
  579. if i = -1 then
  580. i := high(arr)+1;
  581. end
  582. else
  583. i := high(arr)+1;
  584. SetLength(fpc_WideCharArray_To_WideStr,i);
  585. Move(pwidechar(@arr)^, PWideChar(Pointer(@fpc_WideCharArray_To_WideStr[1]))^,i*sizeof(WideChar));
  586. { Terminating Zero }
  587. PWideChar(Pointer(@fpc_WideCharArray_To_WideStr[1])+i*sizeof(WideChar))^:=#0;
  588. end;
  589. {$ifndef FPC_STRTOCHARARRAYPROC}
  590. { inside the compiler, the resulttype is modified to that of the actual }
  591. { chararray we're converting to (JM) }
  592. function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
  593. var
  594. len: SizeInt;
  595. temp: ansistring;
  596. begin
  597. len := length(src);
  598. { make sure we don't dereference src if it can be nil (JM) }
  599. if len > 0 then
  600. widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
  601. len := length(temp);
  602. if len > arraysize then
  603. len := arraysize;
  604. {$r-}
  605. move(temp[1],fpc_widestr_to_chararray[0],len);
  606. fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
  607. {$ifdef RangeCheckWasOn}
  608. {$r+}
  609. {$endif}
  610. end;
  611. { inside the compiler, the resulttype is modified to that of the actual }
  612. { widechararray we're converting to (JM) }
  613. function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray;[public,alias: 'FPC_WIDESTR_TO_WIDECHARARRAY']; compilerproc;
  614. var
  615. len: SizeInt;
  616. begin
  617. len := length(src);
  618. if len > arraysize then
  619. len := arraysize;
  620. {$r-}
  621. { make sure we don't try to access element 1 of the ansistring if it's nil }
  622. if len > 0 then
  623. move(src[1],fpc_widestr_to_widechararray[0],len*SizeOf(WideChar));
  624. fillchar(fpc_widestr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  625. {$ifdef RangeCheckWasOn}
  626. {$r+}
  627. {$endif}
  628. end;
  629. { inside the compiler, the resulttype is modified to that of the actual }
  630. { chararray we're converting to (JM) }
  631. function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray;[public,alias: 'FPC_ANSISTR_TO_WIDECHARARRAY']; compilerproc;
  632. var
  633. len: SizeInt;
  634. temp: widestring;
  635. begin
  636. len := length(src);
  637. { make sure we don't dereference src if it can be nil (JM) }
  638. if len > 0 then
  639. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  640. len := length(temp);
  641. if len > arraysize then
  642. len := arraysize;
  643. {$r-}
  644. move(temp[1],fpc_ansistr_to_widechararray[0],len*sizeof(widechar));
  645. fillchar(fpc_ansistr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  646. {$ifdef RangeCheckWasOn}
  647. {$r+}
  648. {$endif}
  649. end;
  650. function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray;[public,alias: 'FPC_SHORTSTR_TO_WIDECHARARRAY']; compilerproc;
  651. var
  652. len: longint;
  653. temp : widestring;
  654. begin
  655. len := length(src);
  656. { make sure we don't access char 1 if length is 0 (JM) }
  657. if len > 0 then
  658. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  659. len := length(temp);
  660. if len > arraysize then
  661. len := arraysize;
  662. {$r-}
  663. move(temp[1],fpc_shortstr_to_widechararray[0],len*sizeof(widechar));
  664. fillchar(fpc_shortstr_to_widechararray[len],(arraysize-len)*SizeOf(WideChar),0);
  665. {$ifdef RangeCheckWasOn}
  666. {$r+}
  667. {$endif}
  668. end;
  669. {$else ndef FPC_STRTOCHARARRAYPROC}
  670. procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
  671. var
  672. len: SizeInt;
  673. temp: ansistring;
  674. begin
  675. len := length(src);
  676. { make sure we don't dereference src if it can be nil (JM) }
  677. if len > 0 then
  678. widestringmanager.wide2ansimoveproc(pwidechar(@src[1]),temp,len);
  679. len := length(temp);
  680. if len > length(res) then
  681. len := length(res);
  682. {$r-}
  683. move(temp[1],res[0],len);
  684. fillchar(res[len],length(res)-len,0);
  685. {$ifdef RangeCheckWasOn}
  686. {$r+}
  687. {$endif}
  688. end;
  689. procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
  690. var
  691. len: SizeInt;
  692. begin
  693. len := length(src);
  694. if len > length(res) then
  695. len := length(res);
  696. {$r-}
  697. { make sure we don't try to access element 1 of the ansistring if it's nil }
  698. if len > 0 then
  699. move(src[1],res[0],len*SizeOf(WideChar));
  700. fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
  701. {$ifdef RangeCheckWasOn}
  702. {$r+}
  703. {$endif}
  704. end;
  705. procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
  706. var
  707. len: SizeInt;
  708. temp: widestring;
  709. begin
  710. len := length(src);
  711. { make sure we don't dereference src if it can be nil (JM) }
  712. if len > 0 then
  713. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  714. len := length(temp);
  715. if len > length(res) then
  716. len := length(res);
  717. {$r-}
  718. move(temp[1],res[0],len*sizeof(widechar));
  719. fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
  720. {$ifdef RangeCheckWasOn}
  721. {$r+}
  722. {$endif}
  723. end;
  724. procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
  725. var
  726. len: longint;
  727. temp : widestring;
  728. begin
  729. len := length(src);
  730. { make sure we don't access char 1 if length is 0 (JM) }
  731. if len > 0 then
  732. widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
  733. len := length(temp);
  734. if len > length(res) then
  735. len := length(res);
  736. {$r-}
  737. move(temp[1],res[0],len*sizeof(widechar));
  738. fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
  739. {$ifdef RangeCheckWasOn}
  740. {$r+}
  741. {$endif}
  742. end;
  743. {$endif ndef FPC_STRTOCHARARRAYPROC}
  744. Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE']; compilerproc;
  745. {
  746. Compares 2 WideStrings;
  747. The result is
  748. <0 if S1<S2
  749. 0 if S1=S2
  750. >0 if S1>S2
  751. }
  752. Var
  753. MaxI,Temp : SizeInt;
  754. begin
  755. if pointer(S1)=pointer(S2) then
  756. begin
  757. fpc_WideStr_Compare:=0;
  758. exit;
  759. end;
  760. Maxi:=Length(S1);
  761. temp:=Length(S2);
  762. If MaxI>Temp then
  763. MaxI:=Temp;
  764. Temp:=CompareWord(S1[1],S2[1],MaxI);
  765. if temp=0 then
  766. temp:=Length(S1)-Length(S2);
  767. fpc_WideStr_Compare:=Temp;
  768. end;
  769. Function fpc_WideStr_Compare_Equal(const S1,S2 : WideString): SizeInt;[Public,Alias : 'FPC_WIDESTR_COMPARE_EQUAL']; compilerproc;
  770. {
  771. Compares 2 WideStrings for equality only;
  772. The result is
  773. 0 if S1=S2
  774. <>0 if S1<>S2
  775. }
  776. Var
  777. MaxI : SizeInt;
  778. begin
  779. if pointer(S1)=pointer(S2) then
  780. exit(0);
  781. Maxi:=Length(S1);
  782. If MaxI<>Length(S2) then
  783. exit(-1)
  784. else
  785. exit(CompareWord(S1[1],S2[1],MaxI));
  786. end;
  787. Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
  788. begin
  789. if p=nil then
  790. HandleErrorFrame(201,get_frame);
  791. end;
  792. Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
  793. begin
  794. if (index>len) or (Index<1) then
  795. HandleErrorFrame(201,get_frame);
  796. end;
  797. Procedure fpc_WideStr_SetLength(Var S : WideString; l : SizeInt);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; compilerproc;
  798. {
  799. Sets The length of string S to L.
  800. Makes sure S is unique, and contains enough room.
  801. }
  802. Var
  803. Temp : Pointer;
  804. movelen: SizeInt;
  805. begin
  806. if (l>0) then
  807. begin
  808. if Pointer(S)=nil then
  809. begin
  810. { Need a complete new string...}
  811. Pointer(s):=NewWideString(l);
  812. end
  813. { windows doesn't support reallocing widestrings, this code
  814. is anyways subject to be removed because widestrings shouldn't be
  815. ref. counted anymore (FK) }
  816. else
  817. {$ifndef FPC_WINLIKEWIDESTRING}
  818. if
  819. {$ifdef MSWINDOWS}
  820. not winwidestringalloc and
  821. {$endif MSWINDOWS}
  822. (PWideRec(Pointer(S)-WideFirstOff)^.Ref = 1) then
  823. begin
  824. Dec(Pointer(S),WideFirstOff);
  825. if L*sizeof(WideChar)+WideRecLen>MemSize(Pointer(S)) then
  826. reallocmem(pointer(S), L*sizeof(WideChar)+WideRecLen);
  827. Inc(Pointer(S), WideFirstOff);
  828. end
  829. else
  830. {$endif FPC_WINLIKEWIDESTRING}
  831. begin
  832. { Reallocation is needed... }
  833. Temp:=Pointer(NewWideString(L));
  834. if Length(S)>0 then
  835. begin
  836. if l < succ(length(s)) then
  837. movelen := l
  838. { also move terminating null }
  839. else
  840. movelen := succ(length(s));
  841. Move(Pointer(S)^,Temp^,movelen * Sizeof(WideChar));
  842. end;
  843. fpc_widestr_decr_ref(Pointer(S));
  844. Pointer(S):=Temp;
  845. end;
  846. { Force nil termination in case it gets shorter }
  847. PWord(Pointer(S)+l*sizeof(WideChar))^:=0;
  848. {$ifndef FPC_WINLIKEWIDESTRING}
  849. PWideRec(Pointer(S)-WideFirstOff)^.Len:=l*sizeof(WideChar);
  850. {$endif FPC_WINLIKEWIDESTRING}
  851. end
  852. else
  853. begin
  854. { Length=0 }
  855. if Pointer(S)<>nil then
  856. fpc_widestr_decr_ref (Pointer(S));
  857. Pointer(S):=Nil;
  858. end;
  859. end;
  860. {*****************************************************************************
  861. Public functions, In interface.
  862. *****************************************************************************}
  863. function WideCharToString(S : PWideChar) : AnsiString;
  864. begin
  865. result:=WideCharLenToString(s,Length(WideString(s)));
  866. end;
  867. function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
  868. var
  869. temp:widestring;
  870. begin
  871. widestringmanager.Ansi2WideMoveProc(PChar(Src),temp,Length(Src));
  872. if Length(temp)<DestSize then
  873. move(temp[1],Dest^,Length(temp)*SizeOf(WideChar))
  874. else
  875. move(temp[1],Dest^,(DestSize-1)*SizeOf(WideChar));
  876. Dest[DestSize-1]:=#0;
  877. result:=Dest;
  878. end;
  879. function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
  880. begin
  881. //SetLength(result,Len);
  882. widestringmanager.Wide2AnsiMoveproc(S,result,Len);
  883. end;
  884. procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
  885. begin
  886. Dest:=WideCharLenToString(Src,Len);
  887. end;
  888. procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
  889. begin
  890. Dest:=WideCharToString(S);
  891. end;
  892. Function fpc_widestr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_WIDESTR_UNIQUE']; compilerproc;
  893. {$ifdef FPC_WINLIKEWIDESTRING}
  894. begin
  895. pointer(result) := pointer(s);
  896. end;
  897. {$else FPC_WINLIKEWIDESTRING}
  898. {
  899. Make sure reference count of S is 1,
  900. using copy-on-write semantics.
  901. }
  902. Var
  903. SNew : Pointer;
  904. L : SizeInt;
  905. begin
  906. pointer(result) := pointer(s);
  907. If Pointer(S)=Nil then
  908. exit;
  909. if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
  910. begin
  911. L:=PWideRec(Pointer(S)-WideFirstOff)^.len div sizeof(WideChar);
  912. SNew:=NewWideString (L);
  913. Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
  914. PWideRec(SNew-WideFirstOff)^.len:=L * sizeof(WideChar);
  915. fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
  916. pointer(S):=SNew;
  917. pointer(result):=SNew;
  918. end;
  919. end;
  920. {$endif FPC_WINLIKEWIDESTRING}
  921. Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
  922. var
  923. ResultAddress : Pointer;
  924. begin
  925. ResultAddress:=Nil;
  926. dec(index);
  927. if Index < 0 then
  928. Index := 0;
  929. { Check Size. Accounts for Zero-length S, the double check is needed because
  930. Size can be maxint and will get <0 when adding index }
  931. if (Size>Length(S)) or
  932. (Index+Size>Length(S)) then
  933. Size:=Length(S)-Index;
  934. If Size>0 then
  935. begin
  936. If Index<0 Then
  937. Index:=0;
  938. ResultAddress:=Pointer(NewWideString (Size));
  939. if ResultAddress<>Nil then
  940. begin
  941. Move (PWideChar(S)[Index],ResultAddress^,Size*sizeof(WideChar));
  942. PWideRec(ResultAddress-WideFirstOff)^.Len:=Size*sizeof(WideChar);
  943. PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
  944. end;
  945. end;
  946. Pointer(fpc_widestr_Copy):=ResultAddress;
  947. end;
  948. Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
  949. var
  950. i,MaxLen : SizeInt;
  951. pc : pwidechar;
  952. begin
  953. Pos:=0;
  954. if Length(SubStr)>0 then
  955. begin
  956. MaxLen:=Length(source)-Length(SubStr);
  957. i:=0;
  958. pc:=@source[1];
  959. while (i<=MaxLen) do
  960. begin
  961. inc(i);
  962. if (SubStr[1]=pc^) and
  963. (CompareWord(Substr[1],pc^,Length(SubStr))=0) then
  964. begin
  965. Pos:=i;
  966. exit;
  967. end;
  968. inc(pc);
  969. end;
  970. end;
  971. end;
  972. { Faster version for a widechar alone }
  973. Function Pos (c : WideChar; Const s : WideString) : SizeInt;
  974. var
  975. i: SizeInt;
  976. pc : pwidechar;
  977. begin
  978. pc:=@s[1];
  979. for i:=1 to length(s) do
  980. begin
  981. if pc^=c then
  982. begin
  983. pos:=i;
  984. exit;
  985. end;
  986. inc(pc);
  987. end;
  988. pos:=0;
  989. end;
  990. Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
  991. var
  992. i: SizeInt;
  993. pc : pchar;
  994. begin
  995. pc:=@s[1];
  996. for i:=1 to length(s) do
  997. begin
  998. if widechar(pc^)=c then
  999. begin
  1000. pos:=i;
  1001. exit;
  1002. end;
  1003. inc(pc);
  1004. end;
  1005. pos:=0;
  1006. end;
  1007. Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1008. begin
  1009. result:=Pos(WideString(c),s);
  1010. end;
  1011. Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1012. begin
  1013. result:=Pos(WideString(c),s);
  1014. end;
  1015. Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1016. begin
  1017. result:=Pos(c,WideString(s));
  1018. end;
  1019. { Faster version for a char alone. Must be implemented because }
  1020. { pos(c: char; const s: shortstring) also exists, so otherwise }
  1021. { using pos(char,pchar) will always call the shortstring version }
  1022. { (exact match for first argument), also with $h+ (JM) }
  1023. Function Pos (c : Char; Const s : WideString) : SizeInt;
  1024. var
  1025. i: SizeInt;
  1026. wc : widechar;
  1027. pc : pwidechar;
  1028. begin
  1029. wc:=c;
  1030. pc:=@s[1];
  1031. for i:=1 to length(s) do
  1032. begin
  1033. if pc^=wc then
  1034. begin
  1035. pos:=i;
  1036. exit;
  1037. end;
  1038. inc(pc);
  1039. end;
  1040. pos:=0;
  1041. end;
  1042. Procedure Delete (Var S : WideString; Index,Size: SizeInt);
  1043. Var
  1044. LS : SizeInt;
  1045. begin
  1046. If Length(S)=0 then
  1047. exit;
  1048. if index<=0 then
  1049. exit;
  1050. LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len div sizeof(WideChar);
  1051. if (Index<=LS) and (Size>0) then
  1052. begin
  1053. UniqueString (S);
  1054. if Size+Index>LS then
  1055. Size:=LS-Index+1;
  1056. if Index+Size<=LS then
  1057. begin
  1058. Dec(Index);
  1059. Move(PWideChar(S)[Index+Size],PWideChar(S)[Index],(LS-Index+1)*sizeof(WideChar));
  1060. end;
  1061. Setlength(s,LS-Size);
  1062. end;
  1063. end;
  1064. Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
  1065. var
  1066. Temp : WideString;
  1067. LS : SizeInt;
  1068. begin
  1069. If Length(Source)=0 then
  1070. exit;
  1071. if index <= 0 then
  1072. index := 1;
  1073. Ls:=Length(S);
  1074. if index > LS then
  1075. index := LS+1;
  1076. Dec(Index);
  1077. Pointer(Temp) := NewWideString(Length(Source)+LS);
  1078. SetLength(Temp,Length(Source)+LS);
  1079. If Index>0 then
  1080. move (PWideChar(S)^,PWideChar(Temp)^,Index*sizeof(WideChar));
  1081. Move (PWideChar(Source)^,PWideChar(Temp)[Index],Length(Source)*sizeof(WideChar));
  1082. If (LS-Index)>0 then
  1083. Move(PWideChar(S)[Index],PWideChar(temp)[Length(Source)+index],(LS-Index)*sizeof(WideChar));
  1084. S:=Temp;
  1085. end;
  1086. function UpCase(const s : WideString) : WideString;
  1087. begin
  1088. result:=widestringmanager.UpperWideStringProc(s);
  1089. end;
  1090. Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
  1091. var
  1092. BufLen: SizeInt;
  1093. begin
  1094. SetLength(S,Len);
  1095. If (Buf<>Nil) and (Len>0) then
  1096. begin
  1097. BufLen := IndexWord(Buf^, Len+1, 0);
  1098. If (BufLen>0) and (BufLen < Len) then
  1099. Len := BufLen;
  1100. Move (Buf[0],S[1],Len*sizeof(WideChar));
  1101. PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
  1102. end;
  1103. end;
  1104. Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
  1105. var
  1106. BufLen: SizeInt;
  1107. begin
  1108. SetLength(S,Len);
  1109. If (Buf<>Nil) and (Len>0) then
  1110. begin
  1111. BufLen := IndexByte(Buf^, Len+1, 0);
  1112. If (BufLen>0) and (BufLen < Len) then
  1113. Len := BufLen;
  1114. widestringmanager.Ansi2WideMoveProc(Buf,S,Len);
  1115. //PWideChar(Pointer(S)+Len*sizeof(WideChar))^:=#0;
  1116. end;
  1117. end;
  1118. Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; compilerproc;
  1119. Var
  1120. SS : String;
  1121. begin
  1122. fpc_Val_Real_WideStr := 0;
  1123. if length(S) > 255 then
  1124. code := 256
  1125. else
  1126. begin
  1127. SS := S;
  1128. Val(SS,fpc_Val_Real_WideStr,code);
  1129. end;
  1130. end;
  1131. function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
  1132. var ss:shortstring;
  1133. begin
  1134. if length(s)>255 then
  1135. code:=256
  1136. else
  1137. begin
  1138. ss:=s;
  1139. val(ss,fpc_val_enum_widestr,code);
  1140. end;
  1141. end;
  1142. Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_WIDESTR']; compilerproc;
  1143. Var
  1144. SS : String;
  1145. begin
  1146. if length(S) > 255 then
  1147. begin
  1148. fpc_Val_Currency_WideStr:=0;
  1149. code := 256;
  1150. end
  1151. else
  1152. begin
  1153. SS := S;
  1154. Val(SS,fpc_Val_Currency_WideStr,code);
  1155. end;
  1156. end;
  1157. Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; compilerproc;
  1158. Var
  1159. SS : ShortString;
  1160. begin
  1161. fpc_Val_UInt_WideStr := 0;
  1162. if length(S) > 255 then
  1163. code := 256
  1164. else
  1165. begin
  1166. SS := S;
  1167. Val(SS,fpc_Val_UInt_WideStr,code);
  1168. end;
  1169. end;
  1170. Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; compilerproc;
  1171. Var
  1172. SS : ShortString;
  1173. begin
  1174. fpc_Val_SInt_WideStr:=0;
  1175. if length(S)>255 then
  1176. code:=256
  1177. else
  1178. begin
  1179. SS := S;
  1180. fpc_Val_SInt_WideStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
  1181. end;
  1182. end;
  1183. {$ifndef CPU64}
  1184. Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; compilerproc;
  1185. Var
  1186. SS : ShortString;
  1187. begin
  1188. fpc_Val_qword_WideStr:=0;
  1189. if length(S)>255 then
  1190. code:=256
  1191. else
  1192. begin
  1193. SS := S;
  1194. Val(SS,fpc_Val_qword_WideStr,Code);
  1195. end;
  1196. end;
  1197. Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; compilerproc;
  1198. Var
  1199. SS : ShortString;
  1200. begin
  1201. fpc_Val_int64_WideStr:=0;
  1202. if length(S)>255 then
  1203. code:=256
  1204. else
  1205. begin
  1206. SS := S;
  1207. Val(SS,fpc_Val_int64_WideStr,Code);
  1208. end;
  1209. end;
  1210. {$endif CPU64}
  1211. procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString);compilerproc;
  1212. var
  1213. ss : shortstring;
  1214. begin
  1215. str_real(len,fr,d,treal_type(rt),ss);
  1216. s:=ss;
  1217. end;
  1218. procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc;
  1219. var ss:shortstring;
  1220. begin
  1221. fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
  1222. s:=ss;
  1223. end;
  1224. {$ifdef FPC_HAS_STR_CURRENCY}
  1225. procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
  1226. var
  1227. ss : shortstring;
  1228. begin
  1229. str(c:len:fr,ss);
  1230. s:=ss;
  1231. end;
  1232. {$endif FPC_HAS_STR_CURRENCY}
  1233. Procedure fpc_WideStr_SInt(v : ValSint; Len : SizeInt; out S : WideString);compilerproc;
  1234. Var
  1235. SS : ShortString;
  1236. begin
  1237. Str (v:Len,SS);
  1238. S:=SS;
  1239. end;
  1240. Procedure fpc_WideStr_UInt(v : ValUInt;Len : SizeInt; out S : WideString);compilerproc;
  1241. Var
  1242. SS : ShortString;
  1243. begin
  1244. str(v:Len,SS);
  1245. S:=SS;
  1246. end;
  1247. {$ifndef CPU64}
  1248. Procedure fpc_WideStr_Int64(v : Int64; Len : SizeInt; out S : WideString);compilerproc;
  1249. Var
  1250. SS : ShortString;
  1251. begin
  1252. Str (v:Len,SS);
  1253. S:=SS;
  1254. end;
  1255. Procedure fpc_WideStr_Qword(v : Qword;Len : SizeInt; out S : WideString);compilerproc;
  1256. Var
  1257. SS : ShortString;
  1258. begin
  1259. str(v:Len,SS);
  1260. S:=SS;
  1261. end;
  1262. {$endif CPU64}
  1263. function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1264. begin
  1265. if assigned(Source) then
  1266. Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0))
  1267. else
  1268. Result:=0;
  1269. end;
  1270. function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
  1271. var
  1272. i,j : SizeUInt;
  1273. w : word;
  1274. begin
  1275. result:=0;
  1276. if source=nil then
  1277. exit;
  1278. i:=0;
  1279. j:=0;
  1280. if assigned(Dest) then
  1281. begin
  1282. while (i<SourceChars) and (j<MaxDestBytes) do
  1283. begin
  1284. w:=word(Source[i]);
  1285. case w of
  1286. 0..$7f:
  1287. begin
  1288. Dest[j]:=char(w);
  1289. inc(j);
  1290. end;
  1291. $80..$7ff:
  1292. begin
  1293. if j+1>=MaxDestBytes then
  1294. break;
  1295. Dest[j]:=char($c0 or (w shr 6));
  1296. Dest[j+1]:=char($80 or (w and $3f));
  1297. inc(j,2);
  1298. end;
  1299. else
  1300. begin
  1301. if j+2>=MaxDestBytes then
  1302. break;
  1303. Dest[j]:=char($e0 or (w shr 12));
  1304. Dest[j+1]:=char($80 or ((w shr 6)and $3f));
  1305. Dest[j+2]:=char($80 or (w and $3f));
  1306. inc(j,3);
  1307. end;
  1308. end;
  1309. inc(i);
  1310. end;
  1311. if j>MaxDestBytes-1 then
  1312. j:=MaxDestBytes-1;
  1313. Dest[j]:=#0;
  1314. end
  1315. else
  1316. begin
  1317. while i<SourceChars do
  1318. begin
  1319. case word(Source[i]) of
  1320. $0..$7f:
  1321. inc(j);
  1322. $80..$7ff:
  1323. inc(j,2);
  1324. else
  1325. inc(j,3);
  1326. end;
  1327. end;
  1328. end;
  1329. result:=j+1;
  1330. end;
  1331. function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
  1332. begin
  1333. if assigned(Source) then
  1334. Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source))
  1335. else
  1336. Result:=0;
  1337. end;
  1338. function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
  1339. var
  1340. i,j : SizeUInt;
  1341. w: SizeUInt;
  1342. b : byte;
  1343. begin
  1344. if not assigned(Source) then
  1345. begin
  1346. result:=0;
  1347. exit;
  1348. end;
  1349. result:=SizeUInt(-1);
  1350. i:=0;
  1351. j:=0;
  1352. if assigned(Dest) then
  1353. begin
  1354. while (j<MaxDestChars) and (i<SourceBytes) do
  1355. begin
  1356. b:=byte(Source[i]);
  1357. w:=b;
  1358. inc(i);
  1359. // 2 or 3 bytes?
  1360. if b>=$80 then
  1361. begin
  1362. w:=b and $3f;
  1363. if i>=SourceBytes then
  1364. exit;
  1365. // 3 bytes?
  1366. if (b and $20)<>0 then
  1367. begin
  1368. b:=byte(Source[i]);
  1369. inc(i);
  1370. if i>=SourceBytes then
  1371. exit;
  1372. if (b and $c0)<>$80 then
  1373. exit;
  1374. w:=(w shl 6) or (b and $3f);
  1375. end;
  1376. b:=byte(Source[i]);
  1377. w:=(w shl 6) or (b and $3f);
  1378. if (b and $c0)<>$80 then
  1379. exit;
  1380. inc(i);
  1381. end;
  1382. Dest[j]:=WideChar(w);
  1383. inc(j);
  1384. end;
  1385. if j>=MaxDestChars then j:=MaxDestChars-1;
  1386. Dest[j]:=#0;
  1387. end
  1388. else
  1389. begin
  1390. while i<SourceBytes do
  1391. begin
  1392. b:=byte(Source[i]);
  1393. inc(i);
  1394. // 2 or 3 bytes?
  1395. if b>=$80 then
  1396. begin
  1397. if i>=SourceBytes then
  1398. exit;
  1399. // 3 bytes?
  1400. b := b and $3f;
  1401. if (b and $20)<>0 then
  1402. begin
  1403. b:=byte(Source[i]);
  1404. inc(i);
  1405. if i>=SourceBytes then
  1406. exit;
  1407. if (b and $c0)<>$80 then
  1408. exit;
  1409. end;
  1410. if (byte(Source[i]) and $c0)<>$80 then
  1411. exit;
  1412. inc(i);
  1413. end;
  1414. inc(j);
  1415. end;
  1416. end;
  1417. result:=j+1;
  1418. end;
  1419. function UTF8Encode(const s : WideString) : UTF8String;
  1420. var
  1421. i : SizeInt;
  1422. hs : UTF8String;
  1423. begin
  1424. result:='';
  1425. if s='' then
  1426. exit;
  1427. SetLength(hs,length(s)*3);
  1428. i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PWideChar(s),length(s));
  1429. if i>0 then
  1430. begin
  1431. SetLength(hs,i-1);
  1432. result:=hs;
  1433. end;
  1434. end;
  1435. function UTF8Decode(const s : UTF8String): WideString;
  1436. var
  1437. i : SizeInt;
  1438. hs : WideString;
  1439. begin
  1440. result:='';
  1441. if s='' then
  1442. exit;
  1443. SetLength(hs,length(s));
  1444. i:=Utf8ToUnicode(PWideChar(hs),length(hs)+1,pchar(s),length(s));
  1445. if i>0 then
  1446. begin
  1447. SetLength(hs,i-1);
  1448. result:=hs;
  1449. end;
  1450. end;
  1451. function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
  1452. begin
  1453. Result:=Utf8Encode(s);
  1454. end;
  1455. function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
  1456. begin
  1457. Result:=Utf8Decode(s);
  1458. end;
  1459. function WideStringToUCS4String(const s : WideString) : UCS4String;
  1460. var
  1461. i : SizeInt;
  1462. begin
  1463. setlength(result,length(s)+1);
  1464. for i:=1 to length(s) do
  1465. result[i-1]:=UCS4Char(s[i]);
  1466. result[length(s)]:=UCS4Char(0);
  1467. end;
  1468. function UCS4StringToWideString(const s : UCS4String) : WideString;
  1469. var
  1470. i : SizeInt;
  1471. begin
  1472. setlength(result,length(s)-1);
  1473. for i:=1 to length(s)-1 do
  1474. result[i]:=WideChar(s[i-1]);
  1475. end;
  1476. procedure unimplementedwidestring;
  1477. begin
  1478. HandleErrorFrame(215,get_frame);
  1479. end;
  1480. {$warnings off}
  1481. function GenericWideCase(const s : WideString) : WideString;
  1482. begin
  1483. unimplementedwidestring;
  1484. end;
  1485. function CompareWideString(const s1, s2 : WideString) : PtrInt;
  1486. begin
  1487. unimplementedwidestring;
  1488. end;
  1489. function CompareTextWideString(const s1, s2 : WideString): PtrInt;
  1490. begin
  1491. unimplementedwidestring;
  1492. end;
  1493. function CharLengthPChar(const Str: PChar): PtrInt;
  1494. begin
  1495. unimplementedwidestring;
  1496. end;
  1497. {$warnings on}
  1498. procedure initwidestringmanager;
  1499. begin
  1500. fillchar(widestringmanager,sizeof(widestringmanager),0);
  1501. {$ifndef HAS_WIDESTRINGMANAGER}
  1502. widestringmanager.Wide2AnsiMoveProc:=@defaultWide2AnsiMove;
  1503. widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2WideMove;
  1504. widestringmanager.UpperWideStringProc:=@GenericWideCase;
  1505. widestringmanager.LowerWideStringProc:=@GenericWideCase;
  1506. {$endif HAS_WIDESTRINGMANAGER}
  1507. widestringmanager.CompareWideStringProc:=@CompareWideString;
  1508. widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
  1509. widestringmanager.CharLengthPCharProc:=@CharLengthPChar;
  1510. end;