wstrings.inc 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2001 by Florian Klaempfl,
  5. member of the Free Pascal development team.
  6. This file implements support routines for WideStrings 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. @-12 : Longint for maximum size;
  19. @-8 : Longint for size;
  20. @-4 : Longint for reference count;
  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. Maxlen,
  31. len,
  32. ref : Longint;
  33. First : WideChar;
  34. end;
  35. Const
  36. WideRecLen = SizeOf(TWideRec);
  37. WideFirstOff = SizeOf(TWideRec)-sizeof(WideChar);
  38. {
  39. Default WideChar <-> Char conversion is to only convert the
  40. lower 127 chars, all others are translated to spaces.
  41. These routines can be overwritten for the Current Locale
  42. }
  43. procedure Wide2AnsiMove(source:pwidechar;dest:pchar;len:longint);
  44. var
  45. i : longint;
  46. begin
  47. for i:=1 to len do
  48. begin
  49. if word(source^)<128 then
  50. dest^:=char(word(source^))
  51. else
  52. dest^:=' ';
  53. inc(dest);
  54. inc(source);
  55. end;
  56. end;
  57. procedure Ansi2WideMove(source:pchar;dest:pwidechar;len:longint);
  58. var
  59. i : longint;
  60. begin
  61. for i:=1 to len do
  62. begin
  63. if byte(source^)<128 then
  64. dest^:=widechar(byte(source^))
  65. else
  66. dest^:=' ';
  67. inc(dest);
  68. inc(source);
  69. end;
  70. end;
  71. Type
  72. TWide2AnsiMove=procedure(source:pwidechar;dest:pchar;len:longint);
  73. TAnsi2WideMove=procedure(source:pchar;dest:pwidechar;len:longint);
  74. Const
  75. Wide2AnsiMoveProc:TWide2AnsiMove=@Wide2AnsiMove;
  76. Ansi2WideMoveProc:TAnsi2WideMove=@Ansi2WideMove;
  77. (*
  78. Procedure UniqueWideString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
  79. {
  80. Make sure reference count of S is 1,
  81. using copy-on-write semantics.
  82. }
  83. begin
  84. end;
  85. *)
  86. {****************************************************************************
  87. Internal functions, not in interface.
  88. ****************************************************************************}
  89. {$ifdef WideStrDebug}
  90. Procedure DumpWideRec(S : Pointer);
  91. begin
  92. If S=Nil then
  93. Writeln ('String is nil')
  94. Else
  95. Begin
  96. With PWideRec(S-WideFirstOff)^ do
  97. begin
  98. Write ('(Maxlen: ',maxlen);
  99. Write (' Len:',len);
  100. Writeln (' Ref: ',ref,')');
  101. end;
  102. end;
  103. end;
  104. {$endif}
  105. Function NewWideString(Len : Longint) : Pointer;
  106. {
  107. Allocate a new WideString on the heap.
  108. initialize it to zero length and reference count 1.
  109. }
  110. Var
  111. P : Pointer;
  112. begin
  113. { Also add +1 for a terminating zero }
  114. GetMem(P,Len+Len+WideRecLen);
  115. If P<>Nil then
  116. begin
  117. PWideRec(P)^.Maxlen:=Len; { Maximal length }
  118. PWideRec(P)^.Len:=0; { Initial length }
  119. PWideRec(P)^.Ref:=1; { Set reference count }
  120. PWideRec(P)^.First:=#0; { Terminating #0 }
  121. inc(p,WideFirstOff); { Points to string now }
  122. end;
  123. NewWideString:=P;
  124. end;
  125. Procedure DisposeWideString(Var S : Pointer);
  126. {
  127. Deallocates a WideString From the heap.
  128. }
  129. begin
  130. If S=Nil then
  131. exit;
  132. Dec (Longint(S),WideFirstOff);
  133. FreeMem (S);
  134. S:=Nil;
  135. end;
  136. Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);saveregisters;[Public,Alias:'FPC_WIDESTR_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
  137. {
  138. Decreases the ReferenceCount of a non constant widestring;
  139. If the reference count is zero, deallocate the string;
  140. }
  141. Type
  142. plongint = ^longint;
  143. Var
  144. l : plongint;
  145. Begin
  146. { Zero string }
  147. If S=Nil then exit;
  148. { check for constant strings ...}
  149. l:=@PWIDEREC(S-WideFirstOff)^.Ref;
  150. If l^<0 then exit;
  151. { declocked does a MT safe dec and returns true, if the counter is 0 }
  152. If declocked(l^) then
  153. { Ref count dropped to zero }
  154. DisposeWideString (S); { Remove...}
  155. { this pointer is not valid anymore, so set it to zero }
  156. S:=nil;
  157. end;
  158. {$ifdef hascompilerproc}
  159. { alias for internal use }
  160. Procedure fpc_WideStr_Decr_Ref (Var S : Pointer);saveregisters;[external name 'FPC_WIDESTR_DECR_REF'];
  161. {$endif compilerproc}
  162. {$ifdef hascompilerproc}
  163. Procedure fpc_WideStr_Incr_Ref (S : Pointer);saveregisters;[Public,Alias:'FPC_WIDESTR_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
  164. {$else}
  165. Procedure fpc_WideStr_Incr_Ref (Var S : Pointer);saveregisters;[Public,Alias:'FPC_WIDESTR_INCR_REF'];
  166. {$endif compilerproc}
  167. Begin
  168. If S=Nil then
  169. exit;
  170. { Let's be paranoid : Constant string ??}
  171. If PWideRec(S-WideFirstOff)^.Ref<0 then exit;
  172. inclocked(PWideRec(S-WideFirstOff)^.Ref);
  173. end;
  174. {$ifdef hascompilerproc}
  175. { alias for internal use }
  176. Procedure fpc_WideStr_Incr_Ref (S : Pointer);saveregisters;[external name 'FPC_WIDESTR_INCR_REF'];
  177. {$endif compilerproc}
  178. function fpc_WideStr_To_ShortStr (high_of_res: longint;const S2 : WideString): shortstring;[Public, alias: 'FPC_WIDESTR_TO_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  179. {
  180. Converts a WideString to a ShortString;
  181. }
  182. Var
  183. Size : Longint;
  184. begin
  185. if S2='' then
  186. fpc_WideStr_To_ShortStr:=''
  187. else
  188. begin
  189. Size:=Length(S2);
  190. If Size>high_of_res then
  191. Size:=high_of_res;
  192. Wide2AnsiMoveProc(PWideChar(S2),PChar(@fpc_WideStr_To_ShortStr[1]),Size);
  193. byte(fpc_WideStr_To_ShortStr[0]):=Size;
  194. end;
  195. end;
  196. Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString; {$ifdef hascompilerproc} compilerproc; {$endif}
  197. {
  198. Converts a ShortString to a WideString;
  199. }
  200. Var
  201. Size : Longint;
  202. begin
  203. Size:=Length(S2);
  204. Setlength (fpc_ShortStr_To_WideStr,Size);
  205. if Size>0 then
  206. begin
  207. Ansi2WideMoveProc(PChar(@S2[1]),PWideChar(Pointer(fpc_ShortStr_To_WideStr)),Size);
  208. { Terminating Zero }
  209. PWideChar(Pointer(fpc_ShortStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
  210. end;
  211. end;
  212. { old style helper }
  213. {$ifndef hascompilerproc}
  214. Procedure fpc_ShortStr_To_WideStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_WIDESTR'];
  215. begin
  216. s1 := pointer(fpc_ShortStr_To_WideStr(s2));
  217. end;
  218. {$endif hascompilerproc}
  219. Function fpc_WideStr_To_AnsiStr (const S2 : WideString): AnsiString; {$ifdef hascompilerproc} compilerproc; {$endif}
  220. {
  221. Converts a WideString to an AnsiString
  222. }
  223. Var
  224. Size : Longint;
  225. begin
  226. if s2='' then
  227. exit;
  228. Size:=Length(WideString(S2));
  229. Setlength (fpc_WideStr_To_AnsiStr,Size);
  230. if Size>0 then
  231. begin
  232. Wide2AnsiMoveProc(PWideChar(Pointer(S2)),PChar(Pointer(fpc_WideStr_To_AnsiStr)),Size);
  233. { Terminating Zero }
  234. PChar(Pointer(fpc_WideStr_To_AnsiStr)+Size)^:=#0;
  235. end;
  236. end;
  237. { old style helper }
  238. {$ifndef hascompilerproc}
  239. Procedure fpc_WideStr_To_AnsiStr (Var S1 : Pointer;const S2 : WideString);[Public, alias: 'FPC_WIDESTR_TO_ANSISTR'];
  240. begin
  241. s1 := pointer(fpc_WideStr_To_AnsiStr(s2));
  242. end;
  243. {$endif hascompilerproc}
  244. Function fpc_AnsiStr_To_WideStr (Const S2 : AnsiString): WideString; {$ifdef hascompilerproc} compilerproc; {$endif}
  245. {
  246. Converts an AnsiString to a WideString;
  247. }
  248. Var
  249. Size : Longint;
  250. begin
  251. if s2='' then
  252. exit;
  253. Size:=Length(S2);
  254. Setlength (fpc_AnsiStr_To_WideStr,Size);
  255. if Size>0 then
  256. begin
  257. Ansi2WideMoveProc(PChar(S2),PWideChar(Pointer(fpc_AnsiStr_To_WideStr)),Size);
  258. { Terminating Zero }
  259. PWideChar(Pointer(fpc_AnsiStr_To_WideStr)+Size*sizeof(WideChar))^:=#0;
  260. end;
  261. end;
  262. { compilers with widestrings should have compiler procs }
  263. Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
  264. begin
  265. runerror(218);
  266. end;
  267. Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
  268. begin
  269. runerror(218);
  270. end;
  271. Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
  272. begin
  273. runerror(218);
  274. end;
  275. Function fpc_PWideChar_To_LongStr(const p : pwidechar): longstring; compilerproc;
  276. begin
  277. runerror(218);
  278. end;
  279. { old style helper }
  280. {$ifndef hascompilerproc}
  281. Procedure fpc_AnsiStr_To_WideStr (Var S1 : Pointer; Const S2 : AnsiString);[Public, alias: 'FPC_ANSISTR_TO_WIDESTR'];
  282. begin
  283. s1 := pointer(fpc_AnsiStr_To_WideStr(s2));
  284. end;
  285. {$endif hascompilerproc}
  286. { checked against the ansistring routine, 2001-05-27 (FK) }
  287. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_WIDESTR_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
  288. {
  289. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
  290. }
  291. begin
  292. If S2<>nil then
  293. If PWideRec(S2-WideFirstOff)^.Ref>0 then
  294. Inc(PWideRec(S2-WideFirstOff)^.ref);
  295. { Decrease the reference count on the old S1 }
  296. fpc_widestr_decr_ref (S1);
  297. { And finally, have S1 pointing to S2 (or its copy) }
  298. S1:=S2;
  299. end;
  300. {$ifdef hascompilerproc}
  301. { alias for internal use }
  302. Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_WIDESTR_ASSIGN'];
  303. {$endif hascompilerproc}
  304. { checked against the ansistring routine, 2001-05-27 (FK) }
  305. {$ifdef hascompilerproc}
  306. function fpc_WideStr_Concat (const S1,S2 : WideString): WideString; compilerproc;
  307. var
  308. S3: WideString absolute result;
  309. {$else hascompilerproc}
  310. Procedure fpc_WideStr_Concat (S1,S2 : WideString;var S3 : WideString);[Public, alias: 'FPC_WIDESTR_CONCAT'];
  311. {$endif hascompilerproc}
  312. {
  313. Concatenates 2 WideStrings : S1+S2.
  314. Result Goes to S3;
  315. }
  316. Var
  317. Size,Location : Longint;
  318. begin
  319. { only assign if s1 or s2 is empty }
  320. if (S1='') then
  321. S3 := S2
  322. else
  323. if (S2='') then
  324. S3 := S1
  325. else
  326. begin
  327. { create new result }
  328. Size:=Length(S2);
  329. Location:=Length(S1);
  330. SetLength (S3,Size+Location);
  331. Move (S1[1],S3[1],Location*sizeof(WideChar));
  332. Move (S2[1],S3[location+1],(Size+1)*sizeof(WideChar));
  333. end;
  334. end;
  335. Function fpc_Char_To_WideStr(const c : Char): WideString; {$ifdef hascompilerproc} compilerproc; {$endif}
  336. {
  337. Converts a Char to a WideString;
  338. }
  339. begin
  340. if c = #0 then
  341. { result is automatically set to '' }
  342. exit;
  343. Setlength (fpc_Char_To_WideStr,1);
  344. fpc_Char_To_WideStr[1]:=c;
  345. { Terminating Zero }
  346. PWideChar(Pointer(fpc_Char_To_WideStr)+sizeof(WideChar))^:=#0;
  347. end;
  348. { old style helper }
  349. {$ifndef hascompilerproc}
  350. Procedure fpc_Char_To_WideStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_WIDESTR'];
  351. begin
  352. s1 := pointer(fpc_Char_To_WideStr(c));
  353. end;
  354. {$endif hascompilerproc}
  355. Function fpc_PChar_To_WideStr(const p : pchar): WideString; {$ifdef hascompilerproc} compilerproc; {$endif}
  356. Var
  357. L : Longint;
  358. begin
  359. if (not assigned(p)) or (p[0]=#0) Then
  360. { result is automatically set to '' }
  361. exit;
  362. l:=IndexChar(p^,-1,#0);
  363. SetLength(fpc_PChar_To_WideStr,L);
  364. Ansi2WideMoveProc(P,PWideChar(Pointer(fpc_PChar_To_WideStr)),l);
  365. end;
  366. { old style helper }
  367. {$ifndef hascompilerproc}
  368. Procedure fpc_PChar_To_WideStr(var a : WideString;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  369. begin
  370. pointer(a) := pointer(fpc_PChar_To_WideStr(p));
  371. end;
  372. {$endif hascompilerproc}
  373. Function fpc_CharArray_To_WideStr(const arr: array of char): WideString; {$ifdef hascompilerproc} compilerproc; {$endif}
  374. var
  375. i : longint;
  376. begin
  377. if arr[0]=#0 Then
  378. { result is automatically set to '' }
  379. exit;
  380. i:=IndexChar(arr,high(arr)+1,#0);
  381. if i = -1 then
  382. i := high(arr)+1;
  383. SetLength(fpc_CharArray_To_WideStr,i);
  384. Ansi2WideMoveProc (pchar(@arr),PWideChar(Pointer(fpc_CharArray_To_WideStr)),i);
  385. end;
  386. { old style helper }
  387. {$ifndef hascompilerproc}
  388. Procedure fpc_CharArray_To_WideStr(var a : WideString; p: pointer; len: longint); [Public,Alias : 'FPC_CHARARRAY_TO_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  389. var
  390. src: pchar;
  391. i: longint;
  392. begin
  393. src := pchar(p);
  394. if src[0]=#0 Then
  395. begin
  396. pointer(a) := nil;
  397. exit;
  398. end;
  399. i:=IndexChar(src^,len,#0);
  400. if i = -1 then
  401. i := len;
  402. pointer(a) := NewWideString(i);
  403. Ansi2WideMoveProc (src,PWideChar(Pointer(@a[1])),i);
  404. end;
  405. {$endif not hascompilerproc}
  406. {$ifdef hascompilerproc}
  407. { inside the compiler, the resulttype is modified to that of the actual }
  408. { chararray we're converting to (JM) }
  409. function fpc_widestr_to_chararray(arraysize: longint; const src: WideString): fpc_big_chararray;[public,alias: 'FPC_WIDESTR_TO_CHARARRAY']; compilerproc;
  410. var
  411. len: longint;
  412. begin
  413. len := length(src);
  414. if len > arraysize then
  415. len := arraysize;
  416. { make sure we don't dereference src if it can be nil (JM) }
  417. if len > 0 then
  418. wide2ansimoveproc(pwidechar(@src[1]),pchar(@fpc_widestr_to_chararray[0]),len);
  419. fillchar(fpc_widestr_to_chararray[len],arraysize-len,0);
  420. end;
  421. {$endif hascompilerproc}
  422. Function fpc_WideStr_Compare(const S1,S2 : WideString): Longint;[Public,Alias : 'FPC_WIDESTR_COMPARE']; {$ifdef hascompilerproc} compilerproc; {$endif}
  423. {
  424. Compares 2 WideStrings;
  425. The result is
  426. <0 if S1<S2
  427. 0 if S1=S2
  428. >0 if S1>S2
  429. }
  430. Var
  431. MaxI,Temp : Longint;
  432. begin
  433. if pointer(S1)=pointer(S2) then
  434. begin
  435. fpc_WideStr_Compare:=0;
  436. exit;
  437. end;
  438. Maxi:=Length(S1);
  439. temp:=Length(S2);
  440. If MaxI>Temp then
  441. MaxI:=Temp;
  442. Temp:=CompareWord(S1[1],S2[1],MaxI);
  443. if temp=0 then
  444. temp:=Length(S1)-Length(S2);
  445. fpc_WideStr_Compare:=Temp;
  446. end;
  447. Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; {$ifdef hascompilerproc} compilerproc; {$endif}
  448. begin
  449. if p=nil then
  450. HandleErrorFrame(201,get_frame);
  451. end;
  452. Procedure fpc_WideStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
  453. begin
  454. if (index>len) or (Index<1) then
  455. HandleErrorFrame(201,get_frame);
  456. end;
  457. {$ifndef INTERNSETLENGTH}
  458. Procedure SetLength (Var S : WideString; l : Longint);
  459. {$else INTERNSETLENGTH}
  460. Procedure fpc_WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
  461. {$endif INTERNSETLENGTH}
  462. {
  463. Sets The length of string S to L.
  464. Makes sure S is unique, and contains enough room.
  465. }
  466. Var
  467. Temp : Pointer;
  468. begin
  469. if (l>0) then
  470. begin
  471. if Pointer(S)=nil then
  472. begin
  473. { Need a complete new string...}
  474. Pointer(s):=NewWideString(l);
  475. end
  476. else
  477. If (PWideRec(Pointer(S)-WideFirstOff)^.Maxlen < L) or
  478. (PWideRec(Pointer(S)-WideFirstOff)^.Ref <> 1) then
  479. begin
  480. { Reallocation is needed... }
  481. Temp:=Pointer(NewWideString(L));
  482. if Length(S)>0 then
  483. Move(Pointer(S)^,Temp^,L*sizeof(WideChar));
  484. fpc_WideStr_decr_ref(Pointer(S));
  485. Pointer(S):=Temp;
  486. end;
  487. { Force nil termination in case it gets shorter }
  488. PWideChar(Pointer(S)+l*sizeof(WideChar))^:=#0;
  489. PWideRec(Pointer(S)-WideFirstOff)^.Len:=l;
  490. end
  491. else
  492. begin
  493. { Length=0 }
  494. if Pointer(S)<>nil then
  495. fpc_WideStr_decr_ref (Pointer(S));
  496. Pointer(S):=Nil;
  497. end;
  498. end;
  499. {*****************************************************************************
  500. Public functions, In interface.
  501. *****************************************************************************}
  502. function WideCharToString(S : PWideChar) : AnsiString;
  503. begin
  504. result:=WideCharLenToString(s,Length(WideString(s)));
  505. end;
  506. function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : LongInt) : PWideChar;
  507. begin
  508. if Length(Src)<DestSize then
  509. Ansi2WideMoveProc(PChar(Src),Dest,Length(Src))
  510. else
  511. Ansi2WideMoveProc(PChar(Src),Dest,DestSize);
  512. end;
  513. function WideCharLenToString(S : PWideChar;Len : LongInt) : AnsiString;
  514. begin
  515. SetLength(result,Len);
  516. Wide2AnsiMove(S,PChar(result),Len);
  517. end;
  518. procedure WideCharLenToStrVar(Src : PWideChar;Len : LongInt;var Dest : AnsiString);
  519. begin
  520. Dest:=WideCharLenToString(Src,Len);
  521. end;
  522. procedure WideCharToStrVar(S : PWideChar;var Dest : AnsiString);
  523. begin
  524. Dest:=WideCharToString(S);
  525. end;
  526. {$ifndef INTERNLENGTH}
  527. Function Length (Const S : WideString) : Longint;
  528. {
  529. Returns the length of an WideString.
  530. Takes in acount that zero strings are NIL;
  531. }
  532. begin
  533. If Pointer(S)=Nil then
  534. Length:=0
  535. else
  536. Length:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
  537. end;
  538. {$endif INTERNLENGTH}
  539. { overloaded version of UniqueString for interface }
  540. procedure UniqueString(Var S : WideString); [external name 'FPC_WIDESTR_UNIQUE'];
  541. Procedure fpc_widestr_Unique(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE']; {$ifdef hascompilerproc} compilerproc; {$endif}
  542. {
  543. Make sure reference count of S is 1,
  544. using copy-on-write semantics.
  545. }
  546. Var
  547. SNew : Pointer;
  548. L : Longint;
  549. begin
  550. If Pointer(S)=Nil then
  551. exit;
  552. if PWideRec(Pointer(S)-WideFirstOff)^.Ref<>1 then
  553. begin
  554. L:=PWideRec(Pointer(S)-WideFirstOff)^.len;
  555. SNew:=NewWideString (L);
  556. Move (PWideChar(S)^,SNew^,(L+1)*sizeof(WideChar));
  557. PWideRec(SNew-WideFirstOff)^.len:=L;
  558. fpc_widestr_decr_ref (Pointer(S)); { Thread safe }
  559. Pointer(S):=SNew;
  560. end;
  561. end;
  562. {$ifdef interncopy}
  563. Function Fpc_WideStr_Copy (Const S : WideString; Index,Size : Longint) : WideString;compilerproc;
  564. {$else}
  565. Function Copy (Const S : WideString; Index,Size : Longint) : WideString;
  566. {$endif}
  567. var
  568. ResultAddress : Pointer;
  569. begin
  570. ResultAddress:=Nil;
  571. dec(index);
  572. if Index < 0 then
  573. Index := 0;
  574. { Check Size. Accounts for Zero-length S, the double check is needed because
  575. Size can be maxint and will get <0 when adding index }
  576. if (Size>Length(S)) or
  577. (Index+Size>Length(S)) then
  578. Size:=Length(S)-Index;
  579. If Size>0 then
  580. begin
  581. If Index<0 Then
  582. Index:=0;
  583. ResultAddress:=Pointer(NewWideString (Size));
  584. if ResultAddress<>Nil then
  585. begin
  586. Move (PWideChar(S)[Index],ResultAddress^,Size*sizeof(WideChar));
  587. PWideRec(ResultAddress-WideFirstOff)^.Len:=Size;
  588. PWideChar(ResultAddress+Size*sizeof(WideChar))^:=#0;
  589. end;
  590. end;
  591. {$ifdef interncopy}
  592. Pointer(fpc_widestr_Copy):=ResultAddress;
  593. {$else}
  594. Pointer(Copy):=ResultAddress;
  595. {$endif}
  596. end;
  597. Function Pos (Const Substr : WideString; Const Source : WideString) : Longint;
  598. var
  599. i,MaxLen : StrLenInt;
  600. pc : pwidechar;
  601. begin
  602. Pos:=0;
  603. if Length(SubStr)>0 then
  604. begin
  605. MaxLen:=Length(source)-Length(SubStr);
  606. i:=0;
  607. pc:=@source[1];
  608. while (i<=MaxLen) do
  609. begin
  610. inc(i);
  611. if (SubStr[1]=pc^) and
  612. (CompareWord(Substr[1],pc^,Length(SubStr))=0) then
  613. begin
  614. Pos:=i;
  615. exit;
  616. end;
  617. inc(pc);
  618. end;
  619. end;
  620. end;
  621. { Faster version for a widechar alone }
  622. Function Pos (c : WideChar; Const s : WideString) : Longint;
  623. var
  624. i: longint;
  625. pc : pwidechar;
  626. begin
  627. pc:=@s[1];
  628. for i:=1 to length(s) do
  629. begin
  630. if pc^=c then
  631. begin
  632. pos:=i;
  633. exit;
  634. end;
  635. inc(pc);
  636. end;
  637. pos:=0;
  638. end;
  639. { Faster version for a char alone. Must be implemented because }
  640. { pos(c: char; const s: shortstring) also exists, so otherwise }
  641. { using pos(char,pchar) will always call the shortstring version }
  642. { (exact match for first argument), also with $h+ (JM) }
  643. Function Pos (c : Char; Const s : WideString) : Longint;
  644. var
  645. i: longint;
  646. wc : widechar;
  647. pc : pwidechar;
  648. begin
  649. wc:=c;
  650. pc:=@s[1];
  651. for i:=1 to length(s) do
  652. begin
  653. if pc^=wc then
  654. begin
  655. pos:=i;
  656. exit;
  657. end;
  658. inc(pc);
  659. end;
  660. pos:=0;
  661. end;
  662. Procedure Delete (Var S : WideString; Index,Size: Longint);
  663. Var
  664. LS : Longint;
  665. begin
  666. If Length(S)=0 then
  667. exit;
  668. if index<=0 then
  669. exit;
  670. LS:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
  671. if (Index<=LS) and (Size>0) then
  672. begin
  673. UniqueString (S);
  674. if Size+Index>LS then
  675. Size:=LS-Index+1;
  676. if Index+Size<=LS then
  677. begin
  678. Dec(Index);
  679. Move(PWideChar(S)[Index+Size],PWideChar(S)[Index],(LS-Index+1)*sizeof(WideChar));
  680. end;
  681. Setlength(s,LS-Size);
  682. end;
  683. end;
  684. Procedure Insert (Const Source : WideString; Var S : WideString; Index : Longint);
  685. var
  686. Temp : WideString;
  687. LS : Longint;
  688. begin
  689. If Length(Source)=0 then
  690. exit;
  691. if index <= 0 then
  692. index := 1;
  693. Ls:=Length(S);
  694. if index > LS then
  695. index := LS+1;
  696. Dec(Index);
  697. Pointer(Temp) := NewWideString(Length(Source)+LS);
  698. SetLength(Temp,Length(Source)+LS);
  699. If Index>0 then
  700. move (PWideChar(S)^,PWideChar(Temp)^,Index*sizeof(WideChar));
  701. Move (PWideChar(Source)^,PWideChar(Temp)[Index],Length(Source)*sizeof(WideChar));
  702. If (LS-Index)>0 then
  703. Move(PWideChar(S)[Index],PWideChar(temp)[Length(Source)+index],(LS-Index)*sizeof(WideChar));
  704. S:=Temp;
  705. end;
  706. {!!!:Procedure SetString (Var S : WideString; Buf : PWideChar; Len : Longint);
  707. begin
  708. SetLength(S,Len);
  709. Move (Buf[0],S[1],Len*2);
  710. end;}
  711. Function fpc_Val_Real_WideStr(Const S : WideString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  712. Var
  713. SS : String;
  714. begin
  715. fpc_Val_Real_WideStr := 0;
  716. if length(S) > 255 then
  717. code := 256
  718. else
  719. begin
  720. SS := S;
  721. Val(SS,fpc_Val_Real_WideStr,code);
  722. end;
  723. end;
  724. Function fpc_Val_UInt_WideStr (Const S : WideString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  725. Var
  726. SS : ShortString;
  727. begin
  728. fpc_Val_UInt_WideStr := 0;
  729. if length(S) > 255 then
  730. code := 256
  731. else
  732. begin
  733. SS := S;
  734. Val(SS,fpc_Val_UInt_WideStr,code);
  735. end;
  736. end;
  737. Function fpc_Val_SInt_WideStr (DestSize: longint; Const S : WideString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  738. Var
  739. SS : ShortString;
  740. begin
  741. fpc_Val_SInt_WideStr:=0;
  742. if length(S)>255 then
  743. code:=256
  744. else
  745. begin
  746. SS := S;
  747. fpc_Val_SInt_WideStr := fpc_Val_SInt_ShortStr(DestSize,SS,Code);
  748. end;
  749. end;
  750. Function fpc_Val_qword_WideStr (Const S : WideString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  751. Var
  752. SS : ShortString;
  753. begin
  754. fpc_Val_qword_WideStr:=0;
  755. if length(S)>255 then
  756. code:=256
  757. else
  758. begin
  759. SS := S;
  760. Val(SS,fpc_Val_qword_WideStr,Code);
  761. end;
  762. end;
  763. Function fpc_Val_int64_WideStr (Const S : WideString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_WIDESTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  764. Var
  765. SS : ShortString;
  766. begin
  767. fpc_Val_int64_WideStr:=0;
  768. if length(S)>255 then
  769. code:=256
  770. else
  771. begin
  772. SS := S;
  773. Val(SS,fpc_Val_int64_WideStr,Code);
  774. end;
  775. end;
  776. procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : longint;var s : WideString);[public,alias:'FPC_WIDESTR_FLOAT']; {$ifdef hascompilerproc} compilerproc; {$endif}
  777. var
  778. ss : shortstring;
  779. begin
  780. str_real(len,fr,d,treal_type(rt),ss);
  781. s:=ss;
  782. end;
  783. Procedure fpc_WideStr_Longword(C : Longword;Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
  784. Var
  785. SS : ShortString;
  786. begin
  787. str(C:Len,SS);
  788. S:=SS;
  789. end;
  790. Procedure fpc_WideStr_Longint(L : Longint; Len : Longint; Var S : WideString);[Public,Alias : 'FPC_WIDESTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
  791. Var
  792. SS : ShortString;
  793. begin
  794. Str (L:Len,SS);
  795. S:=SS;
  796. end;
  797. {
  798. $Log$
  799. Revision 1.24 2002-10-10 16:08:50 florian
  800. + several widestring/pwidechar related helpers added
  801. Revision 1.23 2002/10/02 18:21:52 peter
  802. * Copy() changed to internal function calling compilerprocs
  803. * FPC_SHORTSTR_COPY renamed to FPC_SHORTSTR_ASSIGN because of the
  804. new copy functions
  805. Revision 1.22 2002/09/26 21:50:38 florian
  806. + some WideString<->AnsiString conversion functions added
  807. Revision 1.21 2002/09/14 11:20:50 carl
  808. * Delphi compatibility fix (with string routines)
  809. Revision 1.20 2002/09/07 21:16:45 carl
  810. * cardinal -> longword
  811. Revision 1.19 2002/09/07 15:07:46 peter
  812. * old logs removed and tabs fixed
  813. Revision 1.18 2002/07/29 21:28:17 florian
  814. * several fixes to get further with linux/ppc system unit compilation
  815. Revision 1.17 2002/04/26 15:19:05 peter
  816. * use saveregisters for incr routines, saves also problems with
  817. the optimizer
  818. Revision 1.16 2002/04/25 20:14:57 peter
  819. * updated compilerprocs
  820. * incr ref count has now a value argument instead of var
  821. }