paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 01:39:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revisions 11665-11738 via svnmerge from

Browse Source 
http://svn.freepascal.org/svn/fpc/branches/unicodestring

........
  r11665 | florian | 2008-08-30 13:30:17 +0200 (Sat, 30 Aug 2008) | 1 line
  
  * continued to work on unicodestring type support
........
  r11666 | florian | 2008-08-30 19:02:26 +0200 (Sat, 30 Aug 2008) | 2 lines
  
  * expectloc for wide/ansi/unicode strings is LOC_CONSTANT or LOC_REGISTER now
........
  r11667 | florian | 2008-08-30 20:42:37 +0200 (Sat, 30 Aug 2008) | 1 line
  
  * more unicodestring stuff fixed, test results on win32 are already good
........
  r11670 | florian | 2008-08-30 23:21:48 +0200 (Sat, 30 Aug 2008) | 2 lines
  
  * first fixes for unix bootstrapping
........
  r11683 | ivost | 2008-09-01 12:46:39 +0200 (Mon, 01 Sep 2008) | 2 lines
  
      * fixed 64bit bug in iconvenc.pas
........
  r11689 | florian | 2008-09-01 23:12:34 +0200 (Mon, 01 Sep 2008) | 1 line
  
  * fixed several errors when building on unix
........
  r11694 | florian | 2008-09-03 20:32:43 +0200 (Wed, 03 Sep 2008) | 1 line
  
  * fixed unix compilation
........
  r11695 | florian | 2008-09-03 21:01:04 +0200 (Wed, 03 Sep 2008) | 1 line
  
  * bootstrapping fix
........
  r11696 | florian | 2008-09-03 21:07:18 +0200 (Wed, 03 Sep 2008) | 1 line
  
  * more bootstrapping fixed
........
  r11698 | florian | 2008-09-03 22:47:54 +0200 (Wed, 03 Sep 2008) | 1 line
  
  + two missing compiler procs exported
........
  r11701 | florian | 2008-09-04 16:42:34 +0200 (Thu, 04 Sep 2008) | 2 lines
  
  + lazarus project for the linux rtl
........
  r11702 | florian | 2008-09-04 16:43:27 +0200 (Thu, 04 Sep 2008) | 2 lines
  
  + set unicode string procedures
........
  r11707 | florian | 2008-09-04 23:23:02 +0200 (Thu, 04 Sep 2008) | 2 lines
  
  * fixed several type casting stuff
........
  r11712 | florian | 2008-09-05 22:46:03 +0200 (Fri, 05 Sep 2008) | 1 line
  
  * fixed unicodestring compilation on windows after recent unix changes
........
  r11713 | florian | 2008-09-05 23:35:12 +0200 (Fri, 05 Sep 2008) | 1 line
  
  + UnicodeString support for Variants
........
  r11715 | florian | 2008-09-06 20:59:54 +0200 (Sat, 06 Sep 2008) | 1 line
  
  * patch by Martin Schreiber for UnicodeString streaming
........
  r11716 | florian | 2008-09-06 22:22:55 +0200 (Sat, 06 Sep 2008) | 2 lines
  
  * fixed test
........
  r11717 | florian | 2008-09-07 10:25:51 +0200 (Sun, 07 Sep 2008) | 1 line
  
  * fixed typo when converting tunicodestring to punicodechar
........
  r11718 | florian | 2008-09-07 11:29:52 +0200 (Sun, 07 Sep 2008) | 3 lines
  
  * fixed writing of UnicodeString properties
  * moved some helper routines to unicode headers
........
  r11734 | florian | 2008-09-09 22:38:55 +0200 (Tue, 09 Sep 2008) | 1 line
  
  * fixed bootstrapping
........
  r11735 | florian | 2008-09-10 11:25:28 +0200 (Wed, 10 Sep 2008) | 2 lines
  
  * first fixes for persisten unicodestrings
........
  r11736 | florian | 2008-09-10 14:31:00 +0200 (Wed, 10 Sep 2008) | 3 lines
  
  Initialized merge tracking via "svnmerge" with revisions "1-11663" from 
  http://svn.freepascal.org/svn/fpc/trunk
........
  r11737 | florian | 2008-09-10 21:06:57 +0200 (Wed, 10 Sep 2008) | 3 lines
  
  * fixed unicodestring <-> variant handling
  * fixed unicodestring property reading
........

git-svn-id: trunk@11739 -
This commit is contained in:
florian 2008-09-10 20:14:31 +00:00
parent ffed6aae86
commit b178b08ba7
69 changed files with 8007 additions and 2302 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.gitattributes vendored
View File

@ -106,6 +106,7 @@ compiler/avr/rgcpu.pas svneol=native#text/plain
compiler/browcol.pas svneol=native#text/plain
compiler/bsdcompile -text
compiler/catch.pas svneol=native#text/plain
compiler/ccharset.pas svneol=native#text/plain
compiler/cclasses.pas svneol=native#text/plain
compiler/cfidwarf.pas svneol=native#text/plain
compiler/cfileutl.pas svneol=native#text/plain
@ -5383,14 +5384,18 @@ rtl/inc/threadvr.inc svneol=native#text/plain
rtl/inc/typefile.inc svneol=native#text/plain
rtl/inc/ucomplex.pp svneol=native#text/plain
rtl/inc/ufloat128.pp svneol=native#text/plain
rtl/inc/ustringh.inc svneol=native#text/plain
rtl/inc/ustrings.inc svneol=native#text/plain
rtl/inc/varerror.inc svneol=native#text/plain
rtl/inc/variant.inc svneol=native#text/plain
rtl/inc/varianth.inc svneol=native#text/plain
rtl/inc/variants.pp svneol=native#text/plain
rtl/inc/video.inc svneol=native#text/plain
rtl/inc/videoh.inc svneol=native#text/plain
rtl/inc/wstring22h.inc svneol=native#text/plain
rtl/inc/wstringh.inc svneol=native#text/plain
rtl/inc/wstrings.inc -text
rtl/inc/wustring22.inc svneol=native#text/plain
rtl/inc/wustrings.inc svneol=native#text/plain
rtl/linux/Makefile svneol=native#text/plain
rtl/linux/Makefile.fpc svneol=native#text/plain
@ -5406,6 +5411,8 @@ rtl/linux/arm/syscall.inc svneol=native#text/plain
rtl/linux/arm/syscallh.inc svneol=native#text/plain
rtl/linux/arm/sysnr.inc svneol=native#text/plain
rtl/linux/arm/ucprt0.as svneol=native#text/plain
rtl/linux/buildrtl.lpi svneol=native#text/plain
rtl/linux/buildrtl.pp svneol=native#text/plain
rtl/linux/bunxsysc.inc svneol=native#text/plain
rtl/linux/errno.inc svneol=native#text/plain
rtl/linux/errnostr.inc -text
@ -7820,6 +7827,7 @@ tests/test/tsetsize.pp svneol=native#text/plain
tests/test/tstack.pp svneol=native#text/plain
tests/test/tstprocv.pp svneol=native#text/plain
tests/test/tstring1.pp svneol=native#text/plain
tests/test/tstring10.pp svneol=native#text/plain
tests/test/tstring2.pp svneol=native#text/plain
tests/test/tstring3.pp svneol=native#text/plain
tests/test/tstring4.pp svneol=native#text/plain
@ -7833,6 +7841,12 @@ tests/test/tstrreal2.pp svneol=native#text/plain
tests/test/tstrreal3.pp -text
tests/test/tsubdecl.pp svneol=native#text/plain
tests/test/tunaligned1.pp svneol=native#text/plain
tests/test/tunistr1.pp svneol=native#text/plain
tests/test/tunistr2.pp svneol=native#text/plain
tests/test/tunistr4.pp svneol=native#text/plain
tests/test/tunistr5.pp svneol=native#text/plain
tests/test/tunistr6.pp svneol=native#text/plain
tests/test/tunistr7.pp svneol=native#text/plain
tests/test/tunit1.pp svneol=native#text/plain
tests/test/tunit2.pp svneol=native#text/plain
tests/test/tunit3.pp svneol=native#text/plain

254
compiler/ccharset.pas Normal file
View File

@ -0,0 +1,254 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Florian Klaempfl
member of the Free Pascal development team.
This unit implements several classes for charset conversions
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{ this unit is included temporarily for 2.2 bootstrapping and can be
removed after the next release after 2.2.2 }
{$mode objfpc}
unit ccharset;
interface
type
tunicodechar = word;
tunicodestring = ^tunicodechar;
tcsconvert = class
// !!!!!!1constructor create;
end;
tunicodecharmappingflag = (umf_noinfo,umf_leadbyte,umf_undefined,
umf_unused);
punicodecharmapping = ^tunicodecharmapping;
tunicodecharmapping = record
unicode : tunicodechar;
flag : tunicodecharmappingflag;
reserved : byte;
end;
punicodemap = ^tunicodemap;
tunicodemap = record
cpname : string[20];
map : punicodecharmapping;
lastchar : longint;
next : punicodemap;
internalmap : boolean;
end;
tcp2unicode = class(tcsconvert)
end;
function loadunicodemapping(const cpname,f : string) : punicodemap;
procedure registermapping(p : punicodemap);
function getmap(const s : string) : punicodemap;
function mappingavailable(const s : string) : boolean;
function getunicode(c : char;p : punicodemap) : tunicodechar;
function getascii(c : tunicodechar;p : punicodemap) : string;
implementation
var
mappings : punicodemap;
function loadunicodemapping(const cpname,f : string) : punicodemap;
var
data : punicodecharmapping;
datasize : longint;
t : text;
s,hs : string;
scanpos,charpos,unicodevalue : longint;
code : word;
flag : tunicodecharmappingflag;
p : punicodemap;
lastchar : longint;
begin
lastchar:=-1;
loadunicodemapping:=nil;
datasize:=256;
getmem(data,sizeof(tunicodecharmapping)*datasize);
assign(t,f);
{$I-}
reset(t);
{$I+}
if ioresult<>0 then
begin
freemem(data,sizeof(tunicodecharmapping)*datasize);
exit;
end;
while not(eof(t)) do
begin
readln(t,s);
if (s[1]='0') and (s[2]='x') then
begin
flag:=umf_unused;
scanpos:=3;
hs:='$';
while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
begin
hs:=hs+s[scanpos];
inc(scanpos);
end;
val(hs,charpos,code);
if code<>0 then
begin
freemem(data,sizeof(tunicodecharmapping)*datasize);
close(t);
exit;
end;
while not(s[scanpos] in ['0','#']) do
inc(scanpos);
if s[scanpos]='#' then
begin
{ special char }
unicodevalue:=$ffff;
hs:=copy(s,scanpos,length(s)-scanpos+1);
if hs='#DBCS LEAD BYTE' then
flag:=umf_leadbyte;
end
else
begin
{ C hex prefix }
inc(scanpos,2);
hs:='$';
while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
begin
hs:=hs+s[scanpos];
inc(scanpos);
end;
val(hs,unicodevalue,code);
if code<>0 then
begin
freemem(data,sizeof(tunicodecharmapping)*datasize);
close(t);
exit;
end;
if charpos>datasize then
begin
{ allocate 1024 bytes more because }
{ if we need more than 256 entries it's }
{ probably a mbcs with a lot of }
{ entries }
datasize:=charpos+1024;
reallocmem(data,sizeof(tunicodecharmapping)*datasize);
end;
flag:=umf_noinfo;
end;
data[charpos].flag:=flag;
data[charpos].unicode:=unicodevalue;
if charpos>lastchar then
lastchar:=charpos;
end;
end;
close(t);
new(p);
p^.lastchar:=lastchar;
p^.cpname:=cpname;
p^.internalmap:=false;
p^.next:=nil;
p^.map:=data;
loadunicodemapping:=p;
end;
procedure registermapping(p : punicodemap);
begin
p^.next:=mappings;
mappings:=p;
end;
function getmap(const s : string) : punicodemap;
var
hp : punicodemap;
const
mapcache : string = '';
mapcachep : punicodemap = nil;
begin
if (mapcache=s) and assigned(mapcachep) and (mapcachep^.cpname=s) then
begin
getmap:=mapcachep;
exit;
end;
hp:=mappings;
while assigned(hp) do
begin
if hp^.cpname=s then
begin
getmap:=hp;
mapcache:=s;
mapcachep:=hp;
exit;
end;
hp:=hp^.next;
end;
getmap:=nil;
end;
function mappingavailable(const s : string) : boolean;
begin
mappingavailable:=getmap(s)<>nil;
end;
function getunicode(c : char;p : punicodemap) : tunicodechar;
begin
if ord(c)<=p^.lastchar then
getunicode:=p^.map[ord(c)].unicode
else
getunicode:=0;
end;
function getascii(c : tunicodechar;p : punicodemap) : string;
var
i : longint;
begin
{ at least map to space }
getascii:=#32;
for i:=0 to p^.lastchar do
if p^.map[i].unicode=c then
begin
if i<256 then
getascii:=chr(i)
else
getascii:=chr(i div 256)+chr(i mod 256);
exit;
end;
end;
var
hp : punicodemap;
initialization
mappings:=nil;
finalization
while assigned(mappings) do
begin
hp:=mappings^.next;
if not(mappings^.internalmap) then
begin
freemem(mappings^.map);
dispose(mappings);
end;
mappings:=hp;
end;
end.

14
compiler/cgobj.pas
View File

@ -3112,13 +3112,15 @@ implementation
paramanager.getintparaloc(pocall_default,1,cgpara1);
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_interfacecom(t) then
incrfunc:='FPC_INTF_INCR_REF'
incrfunc:='FPC_INTF_INCR_REF'
else if is_ansistring(t) then
incrfunc:='FPC_ANSISTR_INCR_REF'
incrfunc:='FPC_ANSISTR_INCR_REF'
else if is_widestring(t) then
incrfunc:='FPC_WIDESTR_INCR_REF'
incrfunc:='FPC_WIDESTR_INCR_REF'
else if is_unicodestring(t) then
incrfunc:='FPC_UNICODESTR_INCR_REF'
else if is_dynamic_array(t) then
incrfunc:='FPC_DYNARRAY_INCR_REF'
incrfunc:='FPC_DYNARRAY_INCR_REF'
else
incrfunc:='';
{ call the special incr function or the generic addref }
@ -3174,6 +3176,8 @@ implementation
decrfunc:='FPC_ANSISTR_DECR_REF'
else if is_widestring(t) then
decrfunc:='FPC_WIDESTR_DECR_REF'
else if is_unicodestring(t) then
decrfunc:='FPC_UNICODESTR_DECR_REF'
else if is_dynamic_array(t) then
begin
decrfunc:='FPC_DYNARRAY_DECR_REF';
@ -3234,6 +3238,7 @@ implementation
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_ansistring(t) or
is_widestring(t) or
is_unicodestring(t) or
is_interfacecom(t) or
is_dynamic_array(t) then
a_load_const_ref(list,OS_ADDR,0,ref)
@ -3266,6 +3271,7 @@ implementation
paramanager.getintparaloc(pocall_default,2,cgpara2);
if is_ansistring(t) or
is_widestring(t) or
is_unicodestring(t) or
is_interfacecom(t) then
begin
g_decrrefcount(list,t,ref);

2
compiler/cp1251.pas
View File

@ -6,7 +6,7 @@ unit cp1251;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

2
compiler/cp437.pas
View File

@ -6,7 +6,7 @@ unit cp437;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

2
compiler/cp850.pas
View File

@ -6,7 +6,7 @@ unit cp850;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

2
compiler/cp866.pas
View File

@ -6,7 +6,7 @@ unit cp866;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

2
compiler/cp8859_1.pas
View File

@ -6,7 +6,7 @@ unit cp8859_1;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

2
compiler/cp8859_5.pas
View File

@ -6,7 +6,7 @@ unit cp8859_5;
implementation
uses
charset;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2};
const
map : array[0..255] of tunicodecharmapping = (

12
compiler/defcmp.pas
View File

@ -413,7 +413,7 @@ implementation
else if (cs_ansistrings in current_settings.localswitches) and
(tstringdef(def_to).stringtype=st_ansistring) then
eq:=te_equal
else if tstringdef(def_to).stringtype=st_widestring then
else if tstringdef(def_to).stringtype in [st_widestring,st_unicodestring] then
eq:=te_convert_l3
else
eq:=te_convert_l1;
@ -425,7 +425,7 @@ implementation
begin
if is_ansistring(def_to) then
eq:=te_convert_l1
else if is_widestring(def_to) then
else if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
@ -446,7 +446,7 @@ implementation
else
eq:=te_convert_l2;
end
else if is_widestring(def_to) then
else if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l3
else
eq:=te_convert_l2;
@ -458,7 +458,7 @@ implementation
if is_widechararray(def_from) or is_open_widechararray(def_from) then
begin
doconv:=tc_chararray_2_string;
if is_widestring(def_to) then
if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l1
else
{ size of widechar array is double due the sizeof a widechar }
@ -490,7 +490,7 @@ implementation
else if is_pwidechar(def_from) then
begin
doconv:=tc_pwchar_2_string;
if is_widestring(def_to) then
if is_widestring(def_to) or is_unicodestring(def_to) then
eq:=te_convert_l1
else
eq:=te_convert_l3;
@ -909,7 +909,7 @@ implementation
else
{ pwidechar(widestring) }
if is_pwidechar(def_to) and
is_widestring(def_from) then
is_wide_or_unicode_string(def_from) then
begin
doconv:=tc_ansistring_2_pchar;
eq:=te_convert_l1;

22
compiler/defutil.pas
View File

@ -165,6 +165,12 @@ interface
{# returns true if p is a wide string type }
function is_widestring(p : tdef) : boolean;
{# true if p is an unicode string def }
function is_unicodestring(p : tdef) : boolean;
{# returns true if p is a wide or unicode string type }
function is_wide_or_unicode_string(p : tdef) : boolean;
{# Returns true if p is a short string type }
function is_shortstring(p : tdef) : boolean;
@ -577,6 +583,22 @@ implementation
end;
{ true if p is an wide string def }
function is_wide_or_unicode_string(p : tdef) : boolean;
begin
is_wide_or_unicode_string:=(p.typ=stringdef) and
(tstringdef(p).stringtype in [st_widestring,st_unicodestring]);
end;
{ true if p is an unicode string def }
function is_unicodestring(p : tdef) : boolean;
begin
is_unicodestring:=(p.typ=stringdef) and
(tstringdef(p).stringtype=st_unicodestring);
end;
{ true if p is an short string def }
function is_shortstring(p : tdef) : boolean;
begin

14
compiler/htypechk.pas
View File

@ -1541,7 +1541,7 @@ implementation
) or
(
is_widechar(p.resultdef) and
is_widestring(def_to)
(is_widestring(def_to) or is_unicodestring(def_to))
) then
eq:=te_equal
end;
@ -2238,7 +2238,7 @@ implementation
(tve_single,tve_dblcurrency,tve_extended,
tve_dblcurrency,tve_dblcurrency,tve_extended);
variantstringdef_cl: array[tstringtype] of tvariantequaltype =
(tve_sstring,tve_astring,tve_astring,tve_wstring,tve_unicodestring);
(tve_sstring,tve_astring,tve_astring,tve_wstring,tve_ustring);
begin
case def.typ of
orddef:
@ -2437,9 +2437,9 @@ implementation
else if (currvcl=tve_boolformal) or
(bestvcl=tve_boolformal) then
if (currvcl=tve_boolformal) then
result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring])
result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
else
result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring])
result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
{ byte is better than everything else (we assume both aren't byte, }
{ since there's only one parameter and that one can't be the same) }
else if (currvcl=tve_byte) or
@ -2497,7 +2497,11 @@ implementation
{ widestring is better than everything left }
else if (currvcl=tve_wstring) or
(bestvcl=tve_wstring) then
result:=1-2*ord(bestvcl=tve_wstring);
result:=1-2*ord(bestvcl=tve_wstring)
{ unicodestring is better than everything left }
else if (currvcl=tve_ustring) or
(bestvcl=tve_ustring) then
result:=1-2*ord(bestvcl=tve_ustring);
{ all possibilities should have been checked now }
if (result=-5) then

25
compiler/nadd.pas
View File

@ -546,11 +546,11 @@ implementation
{ stringconstn only }
{ widechars are converted above to widestrings too }
{ this isn't veryy efficient, but I don't think }
{ this isn't ver y efficient, but I don't think }
{ that it does matter that much (FK) }
if (lt=stringconstn) and (rt=stringconstn) and
(tstringconstnode(left).cst_type=cst_widestring) and
(tstringconstnode(right).cst_type=cst_widestring) then
(tstringconstnode(left).cst_type in [cst_widestring,cst_unicodestring]) and
(tstringconstnode(right).cst_type in [cst_widestring,cst_unicodestring]) then
begin
initwidestring(ws1);
initwidestring(ws2);
@ -835,6 +835,8 @@ implementation
if is_constnode(right) and is_constnode(left) and
(is_widestring(right.resultdef) or
is_widestring(left.resultdef) or
is_unicodestring(right.resultdef) or
is_unicodestring(left.resultdef) or
is_widechar(right.resultdef) or
is_widechar(left.resultdef)) then
begin
@ -1419,8 +1421,13 @@ implementation
begin
if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
begin
{ Is there a unicodestring? }
if is_unicodestring(rd) or is_unicodestring(ld) then
strtype:= st_unicodestring
else
{ Is there a widestring? }
if is_widestring(rd) or is_widestring(ld) or
is_unicodestring(rd) or is_unicodestring(ld) or
is_pwidechar(rd) or is_widechararray(rd) or is_widechar(rd) or is_open_widechararray(rd) or
is_pwidechar(ld) or is_widechararray(ld) or is_widechar(ld) or is_open_widechararray(ld) then
strtype:= st_widestring
@ -1456,6 +1463,13 @@ implementation
if not(is_widestring(ld)) then
inserttypeconv(left,cwidestringtype);
end;
st_unicodestring :
begin
if not(is_unicodestring(rd)) then
inserttypeconv(right,cunicodestringtype);
if not(is_unicodestring(ld)) then
inserttypeconv(left,cunicodestringtype);
end;
st_ansistring :
begin
if not(is_ansistring(rd)) then
@ -2520,6 +2534,11 @@ implementation
{ this is only for add, the comparisaion is handled later }
expectloc:=LOC_REGISTER;
end
else if is_unicodestring(ld) then
begin
{ this is only for add, the comparisaion is handled later }
expectloc:=LOC_REGISTER;
end
else if is_ansistring(ld) then
begin
{ this is only for add, the comparisaion is handled later }

3
compiler/ncal.pas
View File

@ -2772,7 +2772,8 @@ implementation
else
{ ansi/widestrings must be registered, so we can dispose them }
if is_ansistring(resultdef) or
is_widestring(resultdef) then
is_widestring(resultdef) or
is_unicodestring(resultdef) then
begin
expectloc:=LOC_REFERENCE;
end

18
compiler/ncgcnv.pas
View File

@ -148,6 +148,8 @@ interface
location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,location.register);
end;
cst_widestring,
cst_unicodestring,
cst_ansistring :
begin
if tstringconstnode(left).len=0 then
@ -167,20 +169,8 @@ interface
{!!!!!!!}
internalerror(8888);
end;
cst_widestring:
begin
if tstringconstnode(left).len=0 then
begin
reference_reset(hr);
hr.symbol:=current_asmdata.RefAsmSymbol('FPC_EMPTYCHAR');
location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,hr,location.register);
end
else
begin
location_copy(location,left.location);
end;
end;
else
internalerror(200808241);
end;
end;

15
compiler/ncgcon.pas
View File

@ -270,7 +270,7 @@ implementation
pooltype: TConstPoolType;
pool: THashSet;
entry: PHashSetItem;
const
PoolMap: array[tconststringtype] of TConstPoolType = (
sp_conststr,
@ -282,7 +282,7 @@ implementation
);
begin
{ for empty ansistrings we could return a constant 0 }
if (cst_type in [cst_ansistring,cst_widestring]) and (len=0) then
if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) and (len=0) then
begin
location_reset(location,LOC_CONSTANT,OS_ADDR);
location.value:=0;
@ -295,7 +295,7 @@ implementation
if current_asmdata.ConstPools[pooltype] = nil then
current_asmdata.ConstPools[pooltype] := THashSet.Create(64, True, False);
pool := current_asmdata.ConstPools[pooltype];
if cst_type in [cst_widestring, cst_unicodestring] then
entry := pool.FindOrAdd(pcompilerwidestring(value_str)^.data, len*cwidechartype.size)
else
@ -311,7 +311,7 @@ implementation
entry^.Data := lastlabel;
maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
if (len=0) or
not(cst_type in [cst_ansistring,cst_widestring]) then
not(cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(sizeof(pint)))
else
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata,lastlabel.name,const_align(sizeof(pint)));
@ -321,7 +321,7 @@ implementation
begin
if len=0 then
InternalError(2008032301) { empty string should be handled above }
else
else
begin
current_asmdata.getdatalabel(l1);
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(l1));
@ -342,6 +342,7 @@ implementation
current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create_pchar(pc,len+1));
end;
end;
cst_unicodestring,
cst_widestring:
begin
if len=0 then
@ -353,7 +354,7 @@ implementation
{ we use always UTF-16 coding for constants }
{ at least for now }
{ Consts.concat(Tai_const.Create_8bit(2)); }
if tf_winlikewidestring in target_info.flags then
if (cst_type=cst_widestring) and (tf_winlikewidestring in target_info.flags) then
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_32bit(len*cwidechartype.size))
else
begin
@ -401,7 +402,7 @@ implementation
end;
end;
end;
if cst_type in [cst_ansistring, cst_widestring] then
if cst_type in [cst_ansistring, cst_widestring, cst_unicodestring] then
begin
location_reset(location, LOC_REGISTER, OS_ADDR);
reference_reset_symbol(href, lab_str, 0);

2
compiler/ncginl.pas
View File

@ -358,7 +358,7 @@ implementation
hregister:=cg.makeregsize(current_asmdata.CurrAsmList,left.location.register,OS_INT);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,href,hregister);
end;
if is_widestring(left.resultdef) then
if is_widestring(left.resultdef) or is_unicodestring(left.resultdef) then
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,1,hregister);
cg.a_label(current_asmdata.CurrAsmList,lengthlab);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef));

2
compiler/ncgld.pas
View File

@ -1073,7 +1073,7 @@ implementation
freetemp:=false;
end
else
if is_widestring(lt) then
if is_widestring(lt) or is_unicodestring(lt) then
begin
vtype:=vtWideString;
freetemp:=false;

5
compiler/ncgmem.pas
View File

@ -642,7 +642,8 @@ implementation
{ an ansistring needs to be dereferenced }
if is_ansistring(left.resultdef) or
is_widestring(left.resultdef) then
is_widestring(left.resultdef) or
is_unicodestring(left.resultdef) then
begin
if nf_callunique in flags then
internalerror(200304236);
@ -763,6 +764,7 @@ implementation
begin
case tstringdef(left.resultdef).stringtype of
{ it's the same for ansi- and wide strings }
st_unicodestring,
st_widestring,
st_ansistring:
begin
@ -926,6 +928,7 @@ implementation
begin
case tstringdef(left.resultdef).stringtype of
{ it's the same for ansi- and wide strings }
st_unicodestring,
st_widestring,
st_ansistring:
begin

9
compiler/ncgrtti.pas
View File

@ -372,6 +372,11 @@ implementation
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkWString));
write_rtti_name(def);
end;
st_unicodestring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkUString));
write_rtti_name(def);
end;
st_longstring:
begin
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(tkLString));
@ -976,7 +981,7 @@ implementation
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(4));
asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
if (tf_requires_proper_alignment in target_info.flags) then
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
end;
end;
@ -1069,7 +1074,7 @@ implementation
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(4));
asmlists[al_rtti].concat(Tai_const.create_32bit(syms[i].value));
if (tf_requires_proper_alignment in target_info.flags) then
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
asmlists[al_rtti].concat(Tai_const.create_sym_offset(mainrtti,st+offsets[i]));
end;
asmlists[al_rtti].concat(Tai_symbol_end.create(rttilab));

17
compiler/ncnv.pas
View File

@ -917,12 +917,12 @@ implementation
{ we can't do widechar to ansichar conversions at compile time, since }
{ this maps all non-ascii chars to '?' -> loses information }
if (left.nodetype=ordconstn) and
((tstringdef(resultdef).stringtype=st_widestring) or
((tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) or
(torddef(left.resultdef).ordtype=uchar) or
{ >=128 is destroyed }
(tordconstnode(left).value.uvalue<128)) then
begin
if tstringdef(resultdef).stringtype=st_widestring then
if tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring] then
begin
initwidestring(ws);
if torddef(left.resultdef).ordtype=uwidechar then
@ -953,7 +953,7 @@ implementation
if torddef(left.resultdef).ordtype<>uwidechar then
procname := 'fpc_char_to_'
else
procname := 'fpc_wchar_to_';
procname := 'fpc_uchar_to_';
procname:=procname+tstringdef(resultdef).stringtypname;
{ and the parameter }
@ -1193,7 +1193,8 @@ implementation
inserttypeconv(left,cwidestringtype)
else
if is_pchar(resultdef) and
is_widestring(left.resultdef) then
(is_widestring(left.resultdef) or
is_unicodestring(left.resultdef)) then
begin
inserttypeconv(left,cansistringtype);
{ the second pass of second_cstring_to_pchar expects a }
@ -2037,8 +2038,8 @@ implementation
if (convtype=tc_string_2_string) and
(
((not is_widechararray(left.resultdef) and
not is_widestring(left.resultdef)) or
(tstringdef(resultdef).stringtype=st_widestring) or
not is_wide_or_unicode_string(left.resultdef)) or
(tstringdef(resultdef).stringtype in [st_widestring,st_unicodestring]) or
{ non-ascii chars would be replaced with '?' -> loses info }
not hasnonasciichars(pcompilerwidestring(tstringconstnode(left).value_str)))
) then
@ -2530,10 +2531,10 @@ implementation
begin
if (torddef(resultdef).ordtype=uchar) and
(torddef(left.resultdef).ordtype=uwidechar) then
fname := 'fpc_wchar_to_char'
fname := 'fpc_uchar_to_char'
else if (torddef(resultdef).ordtype=uwidechar) and
(torddef(left.resultdef).ordtype=uchar) then
fname := 'fpc_char_to_wchar'
fname := 'fpc_char_to_uchar'
else
internalerror(2007081201);

23
compiler/ncon.pas
View File

@ -866,7 +866,8 @@ implementation
resultdef:=cshortstringtype;
cst_ansistring :
resultdef:=cansistringtype;
cst_unicodestring,
cst_unicodestring :
resultdef:=cunicodestringtype;
cst_widestring :
resultdef:=cwidestringtype;
cst_longstring :
@ -877,11 +878,15 @@ implementation
function tstringconstnode.pass_1 : tnode;
begin
result:=nil;
if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) and
(len=0) then
expectloc:=LOC_CONSTANT
if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) then
begin
if len=0 then
expectloc:=LOC_CONSTANT
else
expectloc:=LOC_REGISTER
end
else
expectloc:=LOC_CREFERENCE;
expectloc:=LOC_CREFERENCE;
end;
@ -920,8 +925,8 @@ implementation
if def.typ<>stringdef then
internalerror(200510011);
{ convert ascii 2 unicode }
if (tstringdef(def).stringtype=st_widestring) and
(cst_type<>cst_widestring) then
if (tstringdef(def).stringtype in [st_widestring,st_unicodestring]) and
not(cst_type in [cst_widestring,cst_unicodestring]) then
begin
initwidestring(pw);
ascii2unicode(value_str,len,pw);
@ -930,8 +935,8 @@ implementation
end
else
{ convert unicode 2 ascii }
if (cst_type=cst_widestring) and
(tstringdef(def).stringtype<>st_widestring) then
if (cst_type in [cst_widestring,cst_unicodestring]) and
not(tstringdef(def).stringtype in [st_widestring,st_unicodestring]) then
begin
pw:=pcompilerwidestring(value_str);
getmem(pc,getlengthwidestring(pw)+1);

8
compiler/ninl.pas
View File

@ -1676,7 +1676,7 @@ implementation
result:=cordconstnode.create(0,u8inttype,false);
end
else if not is_ansistring(left.resultdef) and
not is_widestring(left.resultdef) then
not is_wide_or_unicode_string(left.resultdef) then
result:=cordconstnode.create(tstringdef(left.resultdef).len,u8inttype,true)
end;
end;
@ -2040,8 +2040,8 @@ implementation
{ length) }
if (left.nodetype=typeconvn) and
(ttypeconvnode(left).left.resultdef.typ=stringdef) and
not(is_widestring(left.resultdef) xor
is_widestring(ttypeconvnode(left).left.resultdef)) then
not(is_wide_or_unicode_string(left.resultdef) xor
is_wide_or_unicode_string(ttypeconvnode(left).left.resultdef)) then
begin
hp:=ttypeconvnode(left).left;
ttypeconvnode(left).left:=nil;
@ -2334,7 +2334,7 @@ implementation
result:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry))
end
else if is_ansistring(left.resultdef) or
is_widestring(left.resultdef) then
is_wide_or_unicode_string(left.resultdef) then
CGMessage(type_e_mismatch)
end;
end;

5
compiler/nmem.pas
View File

@ -667,7 +667,7 @@ implementation
ansi/widestring needs to be valid }
valid:=is_dynamic_array(left.resultdef) or
is_ansistring(left.resultdef) or
is_widestring(left.resultdef) or
is_wide_or_unicode_string(left.resultdef) or
{ implicit pointer dereference -> pointer is read }
(left.resultdef.typ = pointerdef);
if valid then
@ -827,7 +827,8 @@ implementation
if (nf_callunique in flags) and
(is_ansistring(left.resultdef) or
(is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
is_unicodestring(left.resultdef) or
(is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
begin
left := ctypeconvnode.create_internal(ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+'_unique',
ccallparanode.create(

14
compiler/nutils.pas
View File

@ -531,7 +531,7 @@ implementation
if not assigned(p.resultdef) then
typecheckpass(p);
if is_ansistring(p.resultdef) or
is_widestring(p.resultdef) or
is_wide_or_unicode_string(p.resultdef) or
is_interfacecom(p.resultdef) or
is_dynamic_array(p.resultdef) then
begin
@ -584,6 +584,18 @@ implementation
cnilnode.create
));
end
else if is_unicodestring(p.resultdef) then
begin
result:=internalstatements(newstatement);
addstatement(newstatement,ccallnode.createintern('fpc_unicodestr_decr_ref',
ccallparanode.create(
ctypeconvnode.create_internal(p,voidpointertype),
nil)));
addstatement(newstatement,cassignmentnode.create(
ctypeconvnode.create_internal(p.getcopy,voidpointertype),
cnilnode.create
));
end
else if is_interfacecom(p.resultdef) then
begin
result:=internalstatements(newstatement);

5
compiler/options.pas
View File

@ -71,7 +71,7 @@ implementation
uses
widestr,
charset,
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2},
SysUtils,
version,
cutils,cmsgs,
@ -2580,6 +2580,9 @@ begin
set_system_macro('FPC_PATCH',patch_nr);
set_system_macro('FPC_FULLVERSION',Format('%d%.02d%.02d',[StrToInt(version_nr),StrToInt(release_nr),StrToInt(patch_nr)]));
if not(target_info.system in system_windows) then
def_system_macro('FPC_WIDESTRING_EQUAL_UNICODESTRING');
for i:=low(tfeature) to high(tfeature) do
if i in features then
def_system_macro('FPC_HAS_FEATURE_'+featurestr[i]);

2
compiler/pdecl.pas
View File

@ -96,7 +96,7 @@ implementation
end;
stringconstn:
begin
if is_widestring(p.resultdef) then
if is_wide_or_unicode_string(p.resultdef) then
begin
initwidestring(pw);
copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw);

3
compiler/pinline.pas
View File

@ -720,6 +720,9 @@ implementation
is_widechararray(paradef) or
is_pwidechar(paradef) then
copynode:=ccallnode.createintern('fpc_widestr_copy',paras)
else
if is_unicodestring(paradef) then
copynode:=ccallnode.createintern('fpc_unicodestr_copy',paras)
else
if is_char(paradef) then
copynode:=ccallnode.createintern('fpc_char_copy',paras)

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 91;
CurrentPPUVersion = 92;
{ buffer sizes }
maxentrysize = 1024;

6
compiler/psystem.pas
View File

@ -157,7 +157,10 @@ implementation
{ should we give a length to the default long and ansi string definition ?? }
clongstringtype:=tstringdef.createlong(-1);
cansistringtype:=tstringdef.createansi;
cwidestringtype:=tstringdef.createwide;
if target_info.system in system_windows then
cwidestringtype:=tstringdef.createwide
else
cwidestringtype:=tstringdef.createunicode;
cunicodestringtype:=tstringdef.createunicode;
{ length=0 for shortstring is open string (needed for readln(string) }
openshortstringtype:=tstringdef.createshort(0);
@ -265,6 +268,7 @@ implementation
addtype('AnsiString',cansistringtype);
addtype('WideString',cwidestringtype);
addtype('UnicodeString',cunicodestringtype);
addtype('OpenString',openshortstringtype);
addtype('Boolean',booltype);
addtype('ByteBool',bool8type);

4
compiler/ptconst.pas
View File

@ -431,7 +431,7 @@ implementation
{ convert to widestring stringconstn }
inserttypeconv(p,cwidestringtype);
if (p.nodetype=stringconstn) and
(tstringconstnode(p).cst_type=cst_widestring) then
(tstringconstnode(p).cst_type in [cst_widestring,cst_unicodestring]) then
begin
pw:=pcompilerwidestring(tstringconstnode(p).value_str);
for i:=0 to tstringconstnode(p).len-1 do
@ -641,7 +641,7 @@ implementation
begin
n:=comp_expr(true);
{ load strval and strlength of the constant tree }
if (n.nodetype=stringconstn) or is_widestring(def) or is_constwidecharnode(n) then
if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) then
begin
{ convert to the expected string type so that
for widestrings strval is a pcompilerwidestring }

2
compiler/scanner.pas
View File

@ -962,7 +962,7 @@ In case not, the value returned can be arbitrary.
else
l:=tarraydef(hdef).highrange;
stringdef:
if is_open_string(hdef) or is_ansistring(hdef) or is_widestring(hdef) then
if is_open_string(hdef) or is_ansistring(hdef) or is_wide_or_unicode_string(hdef) then
Message(type_e_mismatch)
else
l:=tstringdef(hdef).len;

4
compiler/symconst.pas
View File

@ -61,6 +61,8 @@ const
tkDynArray = 21;
tkInterfaceCorba = 22;
tkProcVar = 23;
tkUString = 24;
tkUChar = 25;
otSByte = 0;
otUByte = 1;
@ -446,7 +448,7 @@ type
tvariantequaltype = (
tve_incompatible,
tve_chari64,
tve_unicodestring,
tve_ustring,
tve_wstring,
tve_astring,
tve_sstring,

3
compiler/widestr.pas
View File

@ -28,8 +28,7 @@ unit widestr;
interface
uses
charset,globtype
;
{$ifdef VER2_2}ccharset{$else VER2_2}charset{$endif VER2_2},globtype;
type

167
packages/iconvenc/src/iconvenc.pas
View File

@ -2,7 +2,7 @@
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Marco van de Voort(marco@freepascal.org)
member of the Free Pascal development team
libiconv header translation + a helper routine
http://wiki.freepascal.org/iconvenc
@ -15,7 +15,8 @@
}
unit iconvenc;
interface
interface
{$mode objfpc}{$H+}
{DEFINE LOADDYNAMIC}
@ -23,144 +24,150 @@ interface
uses
baseunix,
{$ifdef LOADDYNAMIC}
dl,
dl,
{$endif}
initc;
const
n=1;
n = 1;
type
Piconv_t = ^iconv_t;
piconv_t = ^iconv_t;
iconv_t = pointer;
Ticonv_open = function (__tocode:Pchar; __fromcode:Pchar):iconv_t;cdecl;
Ticonv = function (__cd:iconv_t; __inbuf:PPchar; __inbytesleft:Psize_t; __outbuf:PPchar; __outbytesleft:Psize_t):size_t;cdecl;
Ticonv_close = function (__cd:iconv_t):longint;cdecl;
Ticonv_open = function(__tocode: pchar; __fromcode: pchar): iconv_t; cdecl;
Ticonv = function(__cd: iconv_t; __inbuf: ppchar; __inbytesleft: psize_t; __outbuf: ppchar; __outbytesleft: psize_t): size_t; cdecl;
Ticonv_close = function(__cd: iconv_t): cint; cdecl;
{$IFNDEF LOADDYNAMIC}
{$ifndef Linux} // and other OSes with iconv in libc.
{$linklib iconv}
{$endif}
function iconv_open (__tocode:Pchar; __fromcode:Pchar):iconv_t;cdecl; external;
function iconv (__cd:iconv_t; __inbuf:PPchar; __inbytesleft:Psize_t; __outbuf:PPchar; __outbytesleft:Psize_t):size_t;cdecl; external;
function iconv_close (__cd:iconv_t):longint;cdecl; external;
function iconv_open(__tocode: pchar; __fromcode: pchar): iconv_t; cdecl; external;
function iconv (__cd: iconv_t; __inbuf: ppchar; __inbytesleft: psize_t; __outbuf: ppchar; __outbytesleft: psize_t): size_t; cdecl; external;
function iconv_close (__cd: iconv_t): cint; cdecl; external;
var
IconvLibFound: Boolean = False;
var
IconvLibFound: boolean = False;
{$ELSE}
var
iconv_lib: Pointer;
iconv_lib: pointer;
iconv_open: Ticonv_open;
iconv: Ticonv;
iconv_close: Ticonv_close;
IconvLibFound: Boolean = True;
function TryLoadLib(LibName:String;var error:string):Boolean; // can be used to load non standard libname
IconvLibFound: boolean = true;
function TryLoadLib(LibName: string; var error: string): boolean; // can be used to load non standard libname
{$endif}
function Iconvert(S:string;var res:string; FromEncoding, ToEncoding: string): cint;
function InitIconv (Var error:string): Boolean;
function Iconvert(s: string; var res: string; FromEncoding, ToEncoding: string): cint;
function InitIconv(var error: string): boolean;
implementation
{$IFDEF LOADDYNAMIC}
function TryLoadLib(LibName:String;var error:string):Boolean;
function resolvesymbol (var funcptr; symbol:string):boolean;
function TryLoadLib(LibName: string; var error: string): boolean;
function resolvesymbol (var funcptr; symbol: string): Boolean;
begin
pointer(funcptr) := pointer(dlsym(iconv_lib, pchar(symbol)));
result := assigned(pointer(funcptr));
if not result then
error := error+#13#10+dlerror();
end;
var
res: boolean;
begin
pointer(funcptr):=pointer(dlsym(iconv_lib, pchar(symbol)));
result:=assigned(pointer(funcptr));
if not result then
error:=error+#13#10+dlerror();
end;
var res:boolean;
begin
result:=false;
Error:=Error+#13#10'Trying '+LibName;
iconv_lib:=dlopen(pchar(libname), RTLD_NOW);
result := false;
Error := Error+#13#10'Trying '+LibName;
iconv_lib := dlopen(pchar(libname), RTLD_NOW);
if Assigned(iconv_lib) then
begin
result:=true;
result := result and resolvesymbol(pointer(iconv),'iconv');
result := result and resolvesymbol(pointer(iconv_open),'iconv_open');
result := result and resolvesymbol(pointer(iconv_close),'iconv_close');
result := true;
result := result and resolvesymbol(pointer(iconv),'iconv');
result := result and resolvesymbol(pointer(iconv_open),'iconv_open');
result := result and resolvesymbol(pointer(iconv_close),'iconv_close');
// if not res then
// dlclose(iconv_lib);
end
else
error:=error+#13#10+dlerror();
end else
error:=error+#13#10+dlerror();
end;
{$ENDIF}
function InitIconv(Var error:string): Boolean;
function InitIconv(var error: string): boolean;
begin
result:=true;
result := true;
{$ifdef LOADDYNAMIC}
error:='';
if not TryLoadLib('libc.so.6',error) then
if not TryLoadLib('libiconv.so',error) then
result:=false;
error := '';
if not TryLoadLib('libc.so.6', error) then
if not TryLoadLib('libiconv.so', error) then
result := false;
{$endif}
iconvlibfound:=iconvlibfound or result;
iconvlibfound := iconvlibfound or result;
end;
function Iconvert(S:string;var res:string; FromEncoding, ToEncoding: string): cint;
function Iconvert(S: string; var Res: string; FromEncoding, ToEncoding: string): cint;
var
InLen, OutLen, Offset: size_t;
Src, Dst: PChar;
Src, Dst: pchar;
H: iconv_t;
lerr: cint;
iconvres : cint;
iconvres: size_t;
begin
H:=iconv_open(PChar(ToEncoding), PChar(FromEncoding));
H := iconv_open(PChar(ToEncoding), PChar(FromEncoding));
if not assigned(H) then
begin
Res:=S;
Exit(-1);
begin
Res := S;
exit(-1);
end;
try
SetLength(Res, Length(S));
InLen:=Length(S);
OutLen:=Length(Res);
Src:=PChar(S);
Dst:=PChar(Res);
while InLen>0 do
InLen := Length(S);
OutLen := Length(Res);
Src := PChar(S);
Dst := PChar(Res);
while InLen > 0 do
begin
iconvres:= iconv(H, @Src, @InLen, @Dst, @OutLen);
if iconvres=Cint(-1) then
iconvres := iconv(H, @Src, @InLen, @Dst, @OutLen);
if iconvres = size_t(-1) then
begin
lerr:=cerrno;
if lerr=ESysEILSEQ then // unknown char, skip
begin
Dst^:=Src^;
Inc(Src);
Inc(Dst);
Dec(InLen);
Dec(OutLen);
end
else
if lerr=ESysE2BIG then
lerr := cerrno;
if lerr = ESysEILSEQ then // unknown char, skip
begin
Dst^ := Src^;
Inc(Src);
Inc(Dst);
Dec(InLen);
Dec(OutLen);
end
else
if lerr = ESysE2BIG then
begin
Offset:=Dst-PChar(Res);
Offset := Dst - PChar(Res);
SetLength(Res, Length(Res)+InLen*2+5); // 5 is minimally one utf-8 char
Dst:=PChar(Res)+Offset;
OutLen:=Length(Res)-Offset;
Dst := PChar(Res) + Offset;
OutLen := Length(Res) - Offset;
end
else
exit(-1)
end;
end;
// iconv has a buffer that needs flushing, specially if the last char is not #0
iconvres:=iconv(H, nil, nil, @Dst, @Outlen);
SetLength(Res, Length(Res)-outlen);
iconv(H, nil, nil, @Dst, @Outlen);
// trim output buffer
SetLength(Res, Length(Res) - Outlen);
finally
iconv_close(H);
end;
result:=0;
end;
Result := 0;
end;
end.

210
rtl/inc/compproc.inc
View File

@ -123,9 +123,16 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring)
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
procedure fpc_WideStr_sint(v : valsint; Len : SizeInt; out S : WideString); compilerproc;
procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compilerproc;
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
procedure fpc_WideStr_sint(v : valsint; Len : SizeInt; out S : WideString); compilerproc;
procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compilerproc;
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
procedure fpc_UnicodeStr_sint(v : valsint; Len : SizeInt; out S : UnicodeString); compilerproc;
procedure fpc_UnicodeStr_uint(v : valuint;Len : SizeInt; out S : UnicodeString); compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef CPU64}
procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring); compilerproc;
@ -137,17 +144,33 @@ procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compi
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
procedure fpc_widestr_qword(v : qword;len : SizeInt;out s : widestring); compilerproc;
procedure fpc_widestr_int64(v : int64;len : SizeInt;out s : widestring); compilerproc;
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
procedure fpc_widestr_qword(v : qword;len : SizeInt;out s : widestring); compilerproc;
procedure fpc_widestr_int64(v : int64;len : SizeInt;out s : widestring); compilerproc;
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
procedure fpc_UnicodeStr_qword(v : qword;len : SizeInt;out s : UnicodeString); compilerproc;
procedure fpc_UnicodeStr_int64(v : int64;len : SizeInt;out s : UnicodeString); compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU64}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPUNONE}
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc;
{$endif}
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
{$endif FPC_HAS_STR_CURRENCY}
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef FPUNONE}
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc;
{$endif}
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
{$endif FPC_HAS_STR_CURRENCY}
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
{$ifndef FPUNONE}
procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString); compilerproc;
{$endif}
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc;
{$endif FPC_HAS_STR_CURRENCY}
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPUNONE}
@ -174,15 +197,28 @@ Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; out Code
Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Currency; compilerproc;
function fpc_Val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:valsint):longint; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPUNONE}
Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc;
{$endif}
Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
function fpc_val_enum_widestr(str2ordindex:pointer;const s:widestring;out code:valsint):longint;compilerproc;
Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef FPUNONE}
Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc;
{$endif}
Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
function fpc_val_Enum_WideStr (str2ordindex:pointer;const s:WideString;out code:valsint):longint;compilerproc;
Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
{$ifndef FPUNONE}
Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; compilerproc;
{$endif}
Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; compilerproc;
function fpc_val_Enum_UnicodeStr(str2ordindex:pointer;const s:UnicodeString;out code:valsint):longint;compilerproc;
Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef CPU64}
Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; compilerproc;
Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; compilerproc;
@ -190,10 +226,18 @@ Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord;
Function fpc_Val_qword_AnsiStr (Const S : AnsiString; out Code : ValSInt): qword;compilerproc;
Function fpc_Val_int64_AnsiStr (Const S : AnsiString; out Code : ValSInt): Int64; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; compilerproc;
Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; compilerproc;
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): qword; compilerproc;
Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU64}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
@ -243,6 +287,11 @@ Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString):
Function fpc_ansistr_Unique(Var S : Pointer): Pointer; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{*****************************************************************************
Widestring support
*****************************************************************************}
{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer); compilerproc;
@ -267,22 +316,11 @@ Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
{$ifndef FPC_STRTOCHARARRAYPROC}
function fpc_widestr_to_chararray(arraysize: SizeInt; const src: WideString): fpc_big_chararray; compilerproc;
Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray; compilerproc;
Function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray; compilerproc;
Function fpc_widestr_to_widechararray(arraysize: SizeInt; const src: WideString): fpc_big_widechararray; compilerproc;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
{$endif ndef FPC_STRTOCHARARRAYPROC}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt; compilerproc;
Function fpc_WideStr_Compare_equal(const S1,S2 : WideString): SizeInt; compilerproc;
Procedure fpc_WideStr_CheckZero(p : pointer); compilerproc;
@ -292,28 +330,131 @@ Function fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideSt
{$ifndef FPC_WINLIKEWIDESTRING}
function fpc_widestr_Unique(Var S : Pointer): Pointer; compilerproc;
{$endif FPC_WINLIKEWIDESTRING}
Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
{$ifndef VER2_2}
Function fpc_UChar_To_WideStr(const c : WideChar): WideString; compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif defined(WINDOWS) or defined(VER2_2)}
{*****************************************************************************
Unicode string support
*****************************************************************************}
{$ifndef VER2_2}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_UnicodeStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_UnicodeStr_Incr_Ref (S : Pointer); compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_UnicodeStr_To_ShortStr (high_of_res: SizeInt;const S2 : UnicodeString): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : UnicodeString); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_ShortStr_To_UnicodeStr (Const S2 : ShortString): UnicodeString; compilerproc;
Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc;
Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compilerproc;
Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc;
Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc;
Procedure fpc_UnicodeStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
{$ifndef STR_CONCAT_PROCS}
Function fpc_UnicodeStr_Concat (const S1,S2 : UnicodeString) : UnicodeString; compilerproc;
function fpc_UnicodeStr_Concat_multi (const sarr:array of Unicodestring): unicodestring; compilerproc;
{$else STR_CONCAT_PROCS}
Procedure fpc_UnicodeStr_Concat (Var DestS : Unicodestring;const S1,S2 : UnicodeString); compilerproc;
Procedure fpc_UnicodeStr_Concat_multi (Var DestS : Unicodestring;const sarr:array of Unicodestring); compilerproc;
{$endif STR_CONCAT_PROCS}
Function fpc_Char_To_UnicodeStr(const c : Char): UnicodeString; compilerproc;
Function fpc_PChar_To_UnicodeStr(const p : pchar): UnicodeString; compilerproc;
Function fpc_CharArray_To_UnicodeStr(const arr: array of char; zerobased: boolean = true): UnicodeString; compilerproc;
{$ifndef FPC_STRTOCHARARRAYPROC}
function fpc_unicodestr_to_chararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_chararray; compilerproc;
Function fpc_shortstr_to_unicodechararray(arraysize: SizeInt; const src: ShortString): fpc_big_unicodechararray; compilerproc;
Function fpc_ansistr_to_unicodechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_unicodechararray; compilerproc;
Function fpc_unicodestr_to_unicodechararray(arraysize: SizeInt; const src: UnicodeString): fpc_big_unicodechararray; compilerproc;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_unicodestr_to_chararray(out res: array of char; const src: UnicodeString); compilerproc;
procedure fpc_shortstr_to_unicodechararray(out res: array of unicodechar; const src: ShortString); compilerproc;
procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc;
procedure fpc_unicodestr_to_unicodechararray(out res: array of unicodechar; const src: UnicodeString); compilerproc;
{$endif ndef FPC_STRTOCHARARRAYPROC}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_UnicodeCharArray_To_ShortStr(const arr: array of unicodechar; zerobased: boolean = true): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_UnicodeCharArray_To_ShortStr(out res : shortstring;const arr: array of unicodechar; zerobased: boolean = true); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_UnicodeCharArray_To_AnsiStr(const arr: array of unicodechar; zerobased: boolean = true): AnsiString; compilerproc;
Function fpc_UnicodeCharArray_To_UnicodeStr(const arr: array of unicodechar; zerobased: boolean = true): UnicodeString; compilerproc;
{$ifndef VER2_2}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc;
Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc;
{$ifndef FPC_STRTOCHARARRAYPROC}
Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray; compilerproc;
Function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray; compilerproc;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc;
procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc;
{$endif ndef FPC_STRTOCHARARRAYPROC}
{$endif VER2_2}
Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt; compilerproc;
Function fpc_UnicodeStr_Compare_equal(const S1,S2 : UnicodeString): SizeInt; compilerproc;
Procedure fpc_UnicodeStr_CheckZero(p : pointer); compilerproc;
Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt); compilerproc;
Procedure fpc_UnicodeStr_SetLength (Var S : UnicodeString; l : SizeInt); compilerproc;
Function fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc;
function fpc_unicodestr_Unique(Var S : Pointer): Pointer; compilerproc;
Function fpc_Char_To_UChar(const c : Char): UnicodeChar; compilerproc;
Function fpc_UChar_To_Char(const c : UnicodeChar): Char; compilerproc;
Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
Function fpc_WChar_To_UnicodeStr(const c : WideChar): UnicodeString; compilerproc;
Function fpc_UChar_To_AnsiStr(const c : UnicodeChar): AnsiString; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_WChar_To_AnsiStr(const c : WideChar): AnsiString; compilerproc;
Function fpc_WChar_To_WideStr(const c : WideChar): WideString; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_PUnicodeChar_To_AnsiStr(const p : punicodechar): ansistring; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_PUnicodeChar_To_UnicodeStr(const p : punicodechar): unicodestring; compilerproc;
Function fpc_PWideChar_To_UnicodeStr(const p : pwidechar): unicodestring; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_PUnicodeChar_To_ShortStr(const p : punicodechar): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_PUnicodeChar_To_ShortStr(out res : shortstring;const p : punicodechar); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif VER2_2}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Function fpc_Char_To_WChar(const c : Char): WideChar; compilerproc;
Function fpc_WChar_To_Char(const c : WideChar): Char; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
{ from text.inc }
@ -325,7 +466,10 @@ Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String);
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); compilerproc;
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); compilerproc;
Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; const S : AnsiString); compilerproc;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideString); compilerproc;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : WideString); compilerproc;
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); compilerproc;
Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); compilerproc;
{$ifndef CPU64}

32
rtl/inc/rtti.inc
View File

@ -40,6 +40,9 @@ Const
tkInt64 = 19;
tkQWord = 20;
tkDynArray = 21;
tkInterfaceCorba = 22;
tkProcVar = 23;
tkUString = 24;
type
@ -130,7 +133,7 @@ end;
Procedure fpc_Initialize (Data,TypeInfo : pointer);[Public,Alias : 'FPC_INITIALIZE']; compilerproc;
begin
case PByte(TypeInfo)^ of
tkAstring,tkWstring,tkInterface,tkDynArray:
tkAstring,tkWstring,tkUString,tkInterface,tkDynArray:
PPchar(Data)^:=Nil;
tkArray:
arrayrtti(data,typeinfo,@int_initialize);
@ -151,11 +154,20 @@ begin
fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil;
end;
{$ifndef VER2_2}
tkUstring :
begin
fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil;
end;
{$endif VER2_2}
{$ifdef WINDOWS}
tkWstring :
begin
fpc_WideStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil;
end;
{$endif WINDOWS}
tkArray :
arrayrtti(data,typeinfo,@int_finalize);
tkObject,
@ -179,8 +191,14 @@ begin
case PByte(TypeInfo)^ of
tkAstring :
fpc_AnsiStr_Incr_Ref(PPointer(Data)^);
{$ifdef WINDOWS}
tkWstring :
fpc_WideStr_Incr_Ref(PPointer(Data)^);
{$endif WINDOWS}
{$ifndef VER2_2}
tkUstring :
fpc_UnicodeStr_Incr_Ref(PPointer(Data)^);
{$endif VER2_2}
tkArray :
arrayrtti(data,typeinfo,@int_addref);
tkobject,
@ -206,8 +224,14 @@ begin
{ see AddRef for comment about below construct (JM) }
tkAstring:
fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
{$ifdef WINDOWS}
tkWstring:
fpc_WideStr_Decr_Ref(PPointer(Data)^);
{$endif WINDOWS}
{$ifndef VER2_2}
tkUString:
fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
{$endif VER2_2}
tkArray:
arrayrtti(data,typeinfo,@fpc_systemDecRef);
tkobject,
@ -245,8 +269,14 @@ begin
fpc_AnsiStr_Decr_Ref(PPointer(Dest)^);
PPointer(Dest)^:=PPointer(Src)^;
end;
{$ifdef WINDOWS}
tkWstring:
fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
{$endif WINDOWS}
{$ifndef VER2_2}
tkUstring:
fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
{$endif VER2_2}
tkArray:
begin
Temp:=PByte(TypeInfo);

10
rtl/inc/system.inc
View File

@ -331,7 +331,15 @@ function aligntoptr(p : pointer) : pointer;inline;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$i wstrings.inc}
{ this is for bootstrappung with 2.2.x }
{$ifdef VER2_2}
{$i wustring22.inc}
{$else VER2_2}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$i wstrings.inc}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$i ustrings.inc}
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$i aliases.inc}

17
rtl/inc/systemh.inc
View File

@ -345,6 +345,14 @@ Type
PUCS2Char = PWideChar;
PWideString = ^WideString;
UnicodeChar = type WideChar;
PUnicodeChar = ^UnicodeChar;
{$ifdef VER2_2}
{ this is only to avoid too much ifdefs in the code }
UnicodeString = type WideString;
{$endif VER2_2}
PUnicodeString = ^UnicodeString;
{ Needed for fpc_get_output }
PText = ^Text;
@ -761,7 +769,14 @@ function lowercase(const s : ansistring) : ansistring;
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$i wstringh.inc}
{$ifdef VER2_2}
{$i wstring22h.inc}
{$else VER2_2}
{$i ustringh.inc}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$i wstringh.inc}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}

28
rtl/inc/text.inc
View File

@ -617,6 +617,32 @@ begin
end;
Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_UNICODESTR']; compilerproc;
{
Writes a UnicodeString to the Text file T
}
var
SLen : longint;
a: ansistring;
begin
If (pointer(S)=nil) or (InOutRes<>0) then
exit;
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
SLen:=Length(s);
If Len>SLen Then
fpc_WriteBlanks(f,Len-SLen);
a:=s;
{ length(a) can be > slen, e.g. after utf-16 -> utf-8 }
fpc_WriteBuffer(f,pchar(a)^,length(a));
end;
fmInput: InOutRes:=105
else InOutRes:=103;
end;
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideString); iocheck; [Public,alias:'FPC_WRITE_TEXT_WIDESTR']; compilerproc;
{
Writes a WideString to the Text file T
@ -641,7 +667,7 @@ begin
else InOutRes:=103;
end;
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SINT']; compilerproc;
var

119
rtl/inc/ustringh.inc Normal file
View File

@ -0,0 +1,119 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2005 by Florian Klaempfl,
member of the Free Pascal development team.
This file implements support routines for UnicodeStrings with FPC
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
Procedure UniqueString (Var S : UnicodeString);external name 'FPC_UNICODESTR_UNIQUE';
Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt;
Function Pos (c : Char; Const s : UnicodeString) : SizeInt;
Function Pos (c : UnicodeChar; Const s : UnicodeString) : SizeInt;
Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function UpCase(const s : UnicodeString) : UnicodeString;
Function UpCase(c:UnicodeChar):UnicodeChar;
Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
function WideCharToString(S : PWideChar) : AnsiString;
function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
function UnicodeCharToString(S : PUnicodeChar) : AnsiString;
function StringToUnicodeChar(const Src : AnsiString;Dest : PUnicodeChar;DestSize : SizeInt) : PUnicodeChar;
function UnicodeCharLenToString(S : PUnicodeChar;Len : SizeInt) : AnsiString;
procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
procedure DefaultUnicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
procedure DefaultAnsi2UnicodeMove(source:pchar;var dest:unicodestring;len:SizeInt);
Type
{ hooks for internationalization
please add new procedures at the end, it makes it easier to detect new procedures }
TUnicodeStringManager = record
Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
// UpperUTF8 : procedure(p:PUTF8String);
UpperWideStringProc : function(const S: WideString): WideString;
// UpperUCS4 : procedure(p:PUCS4Char);
// LowerUTF8 : procedure(p:PUTF8String);
LowerWideStringProc : function(const S: WideString): WideString;
// LowerUCS4 : procedure(p:PUCS4Char);
{
CompUTF8 : function(p1,p2:PUTF8String) : shortint;
CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
CompUCS4 : function(p1,p2:PUC42Char) : shortint;
}
CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
CharLengthPCharProc : function(const Str: PChar): PtrInt;
UpperAnsiStringProc : function(const s : ansistring) : ansistring;
LowerAnsiStringProc : function(const s : ansistring) : ansistring;
CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLowerAnsiStringProc : function(Str: PChar): PChar;
StrUpperAnsiStringProc : function(Str: PChar): PChar;
ThreadInitProc : procedure;
ThreadFiniProc : procedure;
{ this is only different on windows }
Unicode2AnsiMoveProc : procedure(source:punicodechar;var dest:ansistring;len:SizeInt);
Ansi2UnicodeMoveProc : procedure(source:pchar;var dest:unicodestring;len:SizeInt);
UpperUnicodeStringProc : function(const S: UnicodeString): UnicodeString;
LowerUnicodeStringProc : function(const S: UnicodeString): UnicodeString;
CompareUnicodeStringProc : function(const s1, s2 : UnicodeString) : PtrInt;
CompareTextUnicodeStringProc : function(const s1, s2 : UnicodeString): PtrInt;
end;
var
widestringmanager : TUnicodeStringManager;
function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt;
function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
function UTF8Encode(const s : Ansistring) : UTF8String; inline;
function UTF8Encode(const s : UnicodeString) : UTF8String;
function UTF8Decode(const s : UTF8String): UnicodeString;
function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String;
function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString;
function WideStringToUCS4String(const s : WideString) : UCS4String;
function UCS4StringToWideString(const s : UCS4String) : WideString;
Procedure GetWideStringManager (Var Manager : TUnicodeStringManager);
Procedure SetWideStringManager (Const New : TUnicodeStringManager);
Procedure SetWideStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);

2325
rtl/inc/ustrings.inc Normal file
View File

File diff suppressed because it is too large Load Diff

72
rtl/inc/variant.inc
View File

@ -225,25 +225,30 @@ end;
{ Strings }
operator :=(const source : shortstring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.VarFromPStr(Dest,Source);
end;
operator :=(const source : ansistring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.VarFromLStr(Dest,Source);
end;
operator :=(const source : widestring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.VarFromWStr(Dest,Source);
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : UnicodeString) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.VarFromWStr(Dest,Source);
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -412,23 +417,34 @@ end;
{ Strings }
operator :=(const source : variant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.VarToPStr(Dest,Source);
end;
operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
VariantManager.vartolstr(dest,source);
end;
operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
variantmanager.vartowstr(dest,source);
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : variant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
var
res : WideString;
begin
variantmanager.vartowstr(res,source);
dest:=res;
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -623,7 +639,7 @@ procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
begin
if Length(Indices)>0 then
if Length(Indices)>0 then
variantmanager.vararrayput(A, Value, Length(Indices), @Indices[0])
else
variantmanager.vararrayput(A, Value, 0, nil);
@ -632,13 +648,13 @@ procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array
function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
begin
if Length(Indices)>0 then
if Length(Indices)>0 then
Result:=variantmanager.vararrayget(A, Length(Indices), @Indices[0])
else
else
Result:=variantmanager.vararrayget(A, 0, nil);
end;
procedure VarCast(var dest : variant;const source : variant;vartype : longint);
begin
@ -763,6 +779,16 @@ operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}in
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : olevariant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
var
res : WideString;
begin
variantmanager.vartowstr(res,variant(tvardata(source)));
dest:=res;
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
operator :=(const source : olevariant) dest : single;{$ifdef SYSTEMINLINE}inline;{$endif}
@ -931,6 +957,14 @@ operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}in
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : UnicodeString) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
variantmanager.varfromwstr(variant(tvardata(dest)),source);
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
operator :=(const source : single) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
@ -1050,6 +1084,14 @@ Function Pos (w : WideString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (w : UnicodeString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(w,UnicodeString(v));
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v : Variant; Const c : Char) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(ShortString(v),c);
@ -1074,6 +1116,14 @@ Function Pos (v : Variant; Const w : WideString) : SizeInt;{$ifdef SYSTEMINLINE}
end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v : Variant; Const w : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(UnicodeString(v),w);
end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v1 : Variant; Const v2 : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=Pos(WideString(v1),WideString(v2));

18
rtl/inc/varianth.inc
View File

@ -243,6 +243,9 @@ operator :=(const source : widechar) dest : variant;{$ifdef SYSTEMINLINE}inline;
operator :=(const source : shortstring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : ansistring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : widestring) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : UnicodeString) dest : variant;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -297,6 +300,9 @@ operator :=(const source : variant) dest : widechar;{$ifdef SYSTEMINLINE}inline;
operator :=(const source : variant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : variant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : variant) dest : unicodestring;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -388,6 +394,9 @@ operator :=(const source : olevariant) dest : widechar;{$ifdef SYSTEMINLINE}inli
operator :=(const source : olevariant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : olevariant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : olevariant) dest : UnicodeString;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -442,6 +451,9 @@ operator :=(const source : widechar) dest : olevariant;{$ifdef SYSTEMINLINE}inli
operator :=(const source : shortstring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : ansistring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
operator :=(const source : UnicodeString) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{ Floats }
{$ifdef SUPPORT_SINGLE}
@ -474,10 +486,16 @@ Function Pos (c : Char; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline
Function Pos (s : ShortString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (a : AnsiString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (w : WideString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (w : UnicodeString; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v : Variant; Const c : Char) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const s : ShortString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const a : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (v : Variant; Const w : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v : Variant; Const w : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function Pos (v1 : Variant; Const v2 : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
{**********************************************************************

108
rtl/inc/wstring22h.inc Normal file
View File

@ -0,0 +1,108 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2005 by Florian Klaempfl,
member of the Free Pascal development team.
This file implements support routines for WideStrings with FPC 2.2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{ this file can be removed when the 2.2.x series is outdated }
Procedure UniqueString (Var S : WideString);external name 'FPC_WIDESTR_UNIQUE';
Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
Function Pos (c : Char; Const s : WideString) : SizeInt;
Function Pos (c : WideChar; Const s : WideString) : SizeInt;
Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
Function UpCase(const s : WideString) : WideString;
Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
Procedure Delete (Var S : WideString; Index,Size: SizeInt);
Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
function WideCharToString(S : PWideChar) : AnsiString;
function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
procedure DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
Type
{ hooks for internationalization
please add new procedures at the end, it makes it easier to detect new procedures }
TWideStringManager = record
Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
// UpperUTF8 : procedure(p:PUTF8String);
UpperWideStringProc : function(const S: WideString): WideString;
// UpperUCS4 : procedure(p:PUCS4Char);
// LowerUTF8 : procedure(p:PUTF8String);
LowerWideStringProc : function(const S: WideString): WideString;
// LowerUCS4 : procedure(p:PUCS4Char);
{
CompUTF8 : function(p1,p2:PUTF8String) : shortint;
CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
CompUCS4 : function(p1,p2:PUC42Char) : shortint;
}
CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
CharLengthPCharProc : function(const Str: PChar): PtrInt;
UpperAnsiStringProc : function(const s : ansistring) : ansistring;
LowerAnsiStringProc : function(const s : ansistring) : ansistring;
CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLowerAnsiStringProc : function(Str: PChar): PChar;
StrUpperAnsiStringProc : function(Str: PChar): PChar;
ThreadInitProc : procedure;
ThreadFiniProc : procedure;
end;
TUnicodeStringManager = TWideStringManager;
function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
function UTF8Encode(const s : WideString) : UTF8String;
function UTF8Decode(const s : UTF8String): WideString;
function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
function WideStringToUCS4String(const s : WideString) : UCS4String;
function UCS4StringToWideString(const s : UCS4String) : WideString;
{$ifdef MSWINDOWS}
const
winwidestringalloc : boolean = true;
{$endif MSWINDOWS}
var
widestringmanager : TWideStringManager;
Procedure GetWideStringManager (Var Manager : TWideStringManager);
Procedure SetWideStringManager (Const New : TWideStringManager);
Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);
Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);

57
rtl/inc/wstringh.inc
View File

@ -31,73 +31,20 @@ Procedure Delete (Var S : WideString; Index,Size: SizeInt);
Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
function WideCharToString(S : PWideChar) : AnsiString;
function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
procedure DefaultWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
procedure DefaultAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
Type
{ hooks for internationalization
please add new procedures at the end, it makes it easier to detect new procedures }
TWideStringManager = record
Wide2AnsiMoveProc : procedure(source:pwidechar;var dest:ansistring;len:SizeInt);
Ansi2WideMoveProc : procedure(source:pchar;var dest:widestring;len:SizeInt);
// UpperUTF8 : procedure(p:PUTF8String);
UpperWideStringProc : function(const S: WideString): WideString;
// UpperUCS4 : procedure(p:PUCS4Char);
// LowerUTF8 : procedure(p:PUTF8String);
LowerWideStringProc : function(const S: WideString): WideString;
// LowerUCS4 : procedure(p:PUCS4Char);
{
CompUTF8 : function(p1,p2:PUTF8String) : shortint;
CompUCS2 : function(p1,p2:PUCS2Char) : shortint;
CompUCS4 : function(p1,p2:PUC42Char) : shortint;
}
CompareWideStringProc : function(const s1, s2 : WideString) : PtrInt;
CompareTextWideStringProc : function(const s1, s2 : WideString): PtrInt;
CharLengthPCharProc : function(const Str: PChar): PtrInt;
UpperAnsiStringProc : function(const s : ansistring) : ansistring;
LowerAnsiStringProc : function(const s : ansistring) : ansistring;
CompareStrAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
CompareTextAnsiStringProc : function(const S1, S2: ansistring): PtrInt;
StrCompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrICompAnsiStringProc : function(S1, S2: PChar): PtrInt;
StrLCompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLICompAnsiStringProc : function(S1, S2: PChar; MaxLen: PtrUInt): PtrInt;
StrLowerAnsiStringProc : function(Str: PChar): PChar;
StrUpperAnsiStringProc : function(Str: PChar): PChar;
ThreadInitProc : procedure;
ThreadFiniProc : procedure;
end;
type
TWideStringManager = TUnicodeStringManager;
function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PWideChar; SourceChars: SizeUInt): SizeUInt;
function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
function UTF8Encode(const s : WideString) : UTF8String;
function UTF8Decode(const s : UTF8String): WideString;
function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
function WideStringToUCS4String(const s : WideString) : UCS4String;
function UCS4StringToWideString(const s : UCS4String) : WideString;
{$ifdef MSWINDOWS}
const
winwidestringalloc : boolean = true;
{$endif MSWINDOWS}
var
widestringmanager : TWideStringManager;
Procedure GetWideStringManager (Var Manager : TWideStringManager);
Procedure SetWideStringManager (Const New : TWideStringManager);
Procedure SetWideStringManager (Const New : TWideStringManager; Var Old: TWideStringManager);

1518
rtl/inc/wstrings.inc
View File

File diff suppressed because it is too large Load Diff

2021
rtl/inc/wustring22.inc Normal file
View File

File diff suppressed because it is too large Load Diff

1986
rtl/inc/wustrings.inc
View File

File diff suppressed because it is too large Load Diff

64
rtl/linux/buildrtl.lpi Normal file
View File

@ -0,0 +1,64 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="6"/>
<General>
<Flags>
<MainUnitHasUsesSectionForAllUnits Value="False"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<Runnable Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<Title Value="buildrtl"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="buildrtl.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="buildrtl"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<SearchPaths>
<IncludeFiles Value="../inc/;../$(TargetCPU)/;../unix/;../objpas/classes/;../objpas/sysutils/;../objpas/"/>
<OtherUnitFiles Value="../objpas/;../objpas/classes/;../objpas/sysutils/;../inc/;../unix/;../$(TargetCPU)/"/>
<UnitOutputDirectory Value="../units/$(TargetCPU)-linux"/>
</SearchPaths>
<Parsing>
<Style Value="2"/>
</Parsing>
<Other>
<Verbosity>
<ShowNotes Value="False"/>
<ShowHints Value="False"/>
</Verbosity>
<CompilerPath Value="$(CompPath)"/>
<ExecuteBefore>
<Command Value="cmd.exe /c &quot;if not exist ../units/$(TargetCPU)-linux mkdir ../units/$(TargetCPU)-linux&quot;"/>
<ShowAllMessages Value="True"/>
</ExecuteBefore>
</Other>
</CompilerOptions>
</CONFIG>

20
rtl/linux/buildrtl.pp Normal file
View File

@ -0,0 +1,20 @@
{ This unit is only used to edit the rtl with lazarus }
unit buildrtl;
interface
uses
system, unixtype, ctypes, baseunix, strings, objpas,b macpas, syscall, unixutil,
fpintres, heaptrc, lineinfo, lnfodwrf,
termio, unix, linux, initc, cmem, mmx,
crt, printer, linuxvcs,
sysutils, typinfo, math, matrix, varutils,
charset, ucomplex, getopts,
errors, sockets, gpm, ipc, serial, terminfo, dl, dynlibs,
video, mouse, keyboard, variants, types, dateutils, sysconst, fmtbcd,
cthreads, classes, fgl, convutils, stdconvs, strutils, rtlconsts, dos, objects, cwstring, fpcylix, clocale,
exeinfo;
implementation
end.

4
rtl/linux/system.pp
View File

@ -329,5 +329,9 @@ begin
{ threading }
InitSystemThreads;
initvariantmanager;
{$ifdef VER2_2}
initwidestringmanager;
{$else VER2_2}
initunicodestringmanager;
{$endif VER2_2}
end.

29
rtl/objpas/classes/classes.inc
View File

@ -897,13 +897,16 @@ procedure ObjectBinaryToText(Input, Output: TStream);
end;
procedure OutString(s: String);
begin
OutChars(Pointer(S),PChar(S)+Length(S),@CharToOrd);
end;
procedure OutWString(W: WideString);
begin
OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
end;
procedure OutUString(W: UnicodeString);
begin
OutChars(Pointer(W),pwidechar(W)+Length(W),@WideCharToOrd);
end;
@ -1047,6 +1050,25 @@ procedure ObjectBinaryToText(Input, Output: TStream);
end;
end;
function ReadUStr: UnicodeString;
var
len: DWord;
{$IFDEF ENDIAN_BIG}
i : integer;
{$ENDIF}
begin
len := ReadDWord;
SetLength(Result, len);
if (len > 0) then
begin
Input.ReadBuffer(Pointer(@Result[1])^, len*2);
{$IFDEF ENDIAN_BIG}
for i:=1 to len do
Result[i]:=widechar(SwapEndian(word(Result[i])));
{$ENDIF}
end;
end;
procedure ReadPropList(indent: String);
procedure ProcessValue(ValueType: TValueType; Indent: String);
@ -1138,6 +1160,11 @@ procedure ObjectBinaryToText(Input, Output: TStream);
OutWString(ReadWStr);
OutLn('');
end;
vaUString:
begin
OutWString(ReadWStr);
OutLn('');
end;
vaNil:
OutLn('nil');
vaCollection: begin

10
rtl/objpas/classes/classesh.inc
View File

@ -901,7 +901,8 @@ type
TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, vaUTF8String);
vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64,
vaUTF8String, vaUString);
TFilerFlag = (ffInherited, ffChildPos, ffInline);
TFilerFlags = set of TFilerFlag;
@ -967,6 +968,7 @@ type
function ReadStr: String; virtual; abstract;
function ReadString(StringType: TValueType): String; virtual; abstract;
function ReadWideString: WideString;virtual;abstract;
function ReadUnicodeString: UnicodeString;virtual;abstract;
procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract;
procedure SkipValue; virtual; abstract;
end;
@ -1018,6 +1020,7 @@ type
function ReadStr: String; override;
function ReadString(StringType: TValueType): String; override;
function ReadWideString: WideString;override;
function ReadUnicodeString: UnicodeString;override;
procedure SkipComponent(SkipComponentInfos: Boolean); override;
procedure SkipValue; override;
end;
@ -1103,6 +1106,7 @@ type
function ReadBoolean: Boolean;
function ReadChar: Char;
function ReadWideChar: WideChar;
function ReadUnicodeChar: UnicodeChar;
procedure ReadCollection(Collection: TCollection);
function ReadComponent(Component: TComponent): TComponent;
procedure ReadComponents(AOwner, AParent: TComponent;
@ -1121,6 +1125,7 @@ type
function ReadRootComponent(ARoot: TComponent): TComponent;
function ReadString: string;
function ReadWideString: WideString;
function ReadUnicodeString: UnicodeString;
function ReadValue: TValueType;
procedure CopyValue(Writer: TWriter);
property Driver: TAbstractObjectReader read FDriver;
@ -1172,6 +1177,7 @@ type
procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract;
procedure WriteString(const Value: String); virtual; abstract;
procedure WriteWideString(const Value: WideString);virtual;abstract;
procedure WriteUnicodeString(const Value: UnicodeString);virtual;abstract;
end;
{ TBinaryObjectWriter }
@ -1222,6 +1228,7 @@ type
procedure WriteSet(Value: LongInt; SetType: Pointer); override;
procedure WriteString(const Value: String); override;
procedure WriteWideString(const Value: WideString); override;
procedure WriteUnicodeString(const Value: UnicodeString); override;
end;
TTextObjectWriter = class(TAbstractObjectWriter)
@ -1291,6 +1298,7 @@ type
procedure WriteRootComponent(ARoot: TComponent);
procedure WriteString(const Value: string);
procedure WriteWideString(const Value: WideString);
procedure WriteUnicodeString(const Value: UnicodeString);
property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty;

105
rtl/objpas/classes/reader.inc
View File

@ -339,6 +339,25 @@ begin
end;
end;
function TBinaryObjectReader.ReadUnicodeString: UnicodeString;
var
len: DWord;
{$IFDEF ENDIAN_BIG}
i : integer;
{$ENDIF}
begin
len := ReadDWord;
SetLength(Result, len);
if (len > 0) then
begin
Read(Pointer(@Result[1])^, len*2);
{$IFDEF ENDIAN_BIG}
for i:=1 to len do
Result[i]:=UnicodeChar(SwapEndian(word(Result[i])));
{$ENDIF}
end;
end;
procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean);
var
Flags: TFilerFlags;
@ -409,6 +428,11 @@ begin
Count:=LongInt(ReadDWord);
SkipBytes(Count*sizeof(widechar));
end;
vaUString:
begin
Count:=LongInt(ReadDWord);
SkipBytes(Count*sizeof(widechar));
end;
vaSet:
SkipSetBody;
vaCollection:
@ -749,6 +773,19 @@ begin
raise EReadError.Create(SInvalidPropertyValue);
end;
function TReader.ReadUnicodeChar: UnicodeChar;
var
U: UnicodeString;
begin
U := ReadUnicodeString;
if Length(U) = 1 then
Result := U[1]
else
raise EReadError.Create(SInvalidPropertyValue);
end;
procedure TReader.ReadCollection(Collection: TCollection);
var
Item: TCollectionItem;
@ -1172,7 +1209,7 @@ begin
SetOrdProp(Instance, PropInfo, Ord(ReadBoolean));
tkChar:
SetOrdProp(Instance, PropInfo, Ord(ReadChar));
tkWChar:
tkWChar,tkUChar:
SetOrdProp(Instance, PropInfo, Ord(ReadWideChar));
tkEnumeration:
begin
@ -1211,13 +1248,15 @@ begin
end;
end;
tkSString, tkLString, tkAString:
begin
TmpStr:=ReadString;
if Assigned(FOnReadStringProperty) then
FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
SetStrProp(Instance, PropInfo, TmpStr);
end;
tkWstring:
begin
TmpStr:=ReadString;
if Assigned(FOnReadStringProperty) then
FOnReadStringProperty(Self,Instance,PropInfo,TmpStr);
SetStrProp(Instance, PropInfo, TmpStr);
end;
tkUstring:
SetUnicodeStrProp(Instance,PropInfo,ReadUnicodeString);
tkWString:
SetWideStrProp(Instance,PropInfo,ReadWideString);
{!!!: tkVariant}
tkClass:
@ -1365,6 +1404,8 @@ begin
end
else if StringType in [vaWString] then
Result:= FDriver.ReadWidestring
else if StringType in [vaUString] then
Result:= FDriver.ReadUnicodeString
else
raise EReadError.Create(SInvalidPropertyValue);
end;
@ -1375,21 +1416,47 @@ var
s: String;
i: Integer;
begin
if NextValue in [vaWString,vaUTF8String] then
begin
ReadValue;
Result := FDriver.ReadWideString
end
else begin
//data probable from ObjectTextToBinary
s := ReadString;
setlength(result,length(s));
for i:= 1 to length(s) do begin
result[i]:= widechar(ord(s[i])); //no code conversion
if NextValue in [vaWString,vaUString,vaUTF8String] then
//vaUTF8String needs conversion? 2008-09-06 mse
begin
ReadValue;
Result := FDriver.ReadWideString
end
else
begin
//data probable from ObjectTextToBinary
s := ReadString;
setlength(result,length(s));
for i:= 1 to length(s) do begin
result[i]:= widechar(ord(s[i])); //no code conversion
end;
end;
end;
function TReader.ReadUnicodeString: UnicodeString;
var
s: String;
i: Integer;
begin
if NextValue in [vaWString,vaUString,vaUTF8String] then
//vaUTF8String needs conversion? 2008-09-06 mse
begin
ReadValue;
Result := FDriver.ReadUnicodeString
end
else
begin
//data probable from ObjectTextToBinary
s := ReadString;
setlength(result,length(s));
for i:= 1 to length(s) do begin
result[i]:= UnicodeChar(ord(s[i])); //no code conversion
end;
end;
end;
function TReader.ReadValue: TValueType;
begin
Result := FDriver.ReadValue;

44
rtl/objpas/classes/writer.inc
View File

@ -319,6 +319,29 @@ begin
{$ENDIF}
end;
end;
procedure TBinaryObjectWriter.WriteUnicodeString(const Value: UnicodeString);
var len : longword;
{$IFDEF ENDIAN_BIG}
i : integer;
us : UnicodeString;
{$ENDIF}
begin
WriteValue(vaUString);
len:=Length(Value);
WriteDWord(len);
if len > 0 then
begin
{$IFDEF ENDIAN_BIG}
setlength(us,len);
for i:=1 to len do
us[i]:=widechar(SwapEndian(word(Value[i])));
Write(us[1], len*sizeof(UnicodeChar));
{$ELSE}
Write(Value[1], len*sizeof(UnicodeChar));
{$ENDIF}
end;
end;
procedure TBinaryObjectWriter.FlushBuffer;
begin
@ -737,6 +760,7 @@ var
DefMethodValue: TMethod;
WStrValue, WDefStrValue: WideString;
StrValue, DefStrValue: String;
UStrValue, UDefStrValue: UnicodeString;
AncestorObj: TObject;
Component: TComponent;
ObjValue: TObject;
@ -876,6 +900,21 @@ begin
Driver.EndProperty;
end;
end;
tkUString:
begin
UStrValue := GetUnicodeStrProp(Instance, PropInfo);
if HasAncestor then
UDefStrValue := GetUnicodeStrProp(Ancestor, PropInfo)
else
SetLength(UDefStrValue, 0);
if UStrValue <> UDefStrValue then
begin
Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name);
WriteUnicodeString(UStrValue);
Driver.EndProperty;
end;
end;
{!!!: tkVariant:}
tkClass:
begin
@ -1013,3 +1052,8 @@ begin
Driver.WriteWideString(Value);
end;
procedure TWriter.WriteUnicodeString(const Value: UnicodeString);
begin
Driver.WriteUnicodeString(Value);
end;

4
rtl/objpas/sysutils/sysformt.inc
View File

@ -143,7 +143,11 @@ Var ChPos,OldPos,ArgPos,DoArg,Len : SizeInt;
ReadWidth;
ReadPrec;
{$ifdef INWIDEFORMAT}
{$ifdef VER2_2}
FormatChar:=UpCase(Fmt[ChPos])[1];
{$else VER2_2}
FormatChar:=UpCase(UnicodeChar(Fmt[ChPos]));
{$endif VER2_2}
if word(FormatChar)>255 then
ReadFormat:=#255
else

94
rtl/objpas/typinfo.pp
View File

@ -38,7 +38,7 @@ unit typinfo;
tkSet,tkMethod,tkSString,tkLString,tkAString,
tkWString,tkVariant,tkArray,tkRecord,tkInterface,
tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
tkDynArray,tkInterfaceRaw);
tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar);
TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
@ -85,7 +85,7 @@ unit typinfo;
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
case TTypeKind of
tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
tkUnKnown,tkLString,tkWString,tkAString,tkVariant,tkUString:
();
tkInteger,tkChar,tkEnumeration,tkWChar,tkSet:
(OrdType : TOrdType;
@ -252,6 +252,11 @@ Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
Procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
Procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
{$ifndef FPUNONE}
Function GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
Function GetFloatProp(Instance: TObject; const PropName: string): Extended;
@ -1397,6 +1402,91 @@ begin
end;
end;
Function GetUnicodeStrProp(Instance: TObject; const PropName: string): UnicodeString;
begin
Result:=GetUnicodeStrProp(Instance, FindPropInfo(Instance, PropName));
end;
procedure SetUnicodeStrProp(Instance: TObject; const PropName: string; const Value: UnicodeString);
begin
SetUnicodeStrProp(Instance,FindPropInfo(Instance,PropName),Value);
end;
Function GetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;
type
TGetUnicodeStrProcIndex=function(index:longint):UnicodeString of object;
TGetUnicodeStrProc=function():UnicodeString of object;
var
AMethod : TMethod;
begin
Result:='';
case Propinfo^.PropType^.Kind of
tkSString,tkAString:
Result:=GetStrProp(Instance,PropInfo);
tkWString:
Result:=GetWideStrProp(Instance,PropInfo);
tkUString:
begin
case (PropInfo^.PropProcs) and 3 of
ptField:
Result := PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
ptstatic,
ptvirtual :
begin
if (PropInfo^.PropProcs and 3)=ptStatic then
AMethod.Code:=PropInfo^.GetProc
else
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
AMethod.Data:=Instance;
if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
Result:=TGetUnicodeStrProcIndex(AMethod)(PropInfo^.Index)
else
Result:=TGetUnicodeStrProc(AMethod)();
end;
end;
end;
end;
end;
Procedure SetUnicodeStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);
type
TSetUnicodeStrProcIndex=procedure(index:longint;s:UnicodeString) of object;
TSetUnicodeStrProc=procedure(s:UnicodeString) of object;
var
AMethod : TMethod;
begin
case Propinfo^.PropType^.Kind of
tkSString,tkAString:
SetStrProp(Instance,PropInfo,Value);
tkWString:
SetWideStrProp(Instance,PropInfo,Value);
tkUString:
begin
case (PropInfo^.PropProcs shr 2) and 3 of
ptField:
PUnicodeString(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
ptstatic,
ptvirtual :
begin
if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
AMethod.Code:=PropInfo^.SetProc
else
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
AMethod.Data:=Instance;
if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
TSetUnicodeStrProcIndex(AMethod)(PropInfo^.Index,Value)
else
TSetUnicodeStrProc(AMethod)(Value);
end;
end;
end;
end;
end;
{$ifndef FPUNONE}

12
rtl/unix/cwstring.pp
View File

@ -705,7 +705,7 @@ end;
Procedure SetCWideStringManager;
Var
CWideStringManager : TWideStringManager;
CWideStringManager : TUnicodeStringManager;
begin
CWideStringManager:=widestringmanager;
With CWideStringManager do
@ -733,8 +733,15 @@ begin
StrUpperAnsiStringProc:=@AnsiStrUpper;
ThreadInitProc:=@InitThread;
ThreadFiniProc:=@FiniThread;
{$ifndef VER2_2}
{ Unicode }
Unicode2AnsiMoveProc:=@Wide2AnsiMove;
Ansi2UnicodeMoveProc:=@Ansi2WideMove;
UpperUnicodeStringProc:=@UpperWideString;
LowerUnicodeStringProc:=@LowerWideString;
{$endif VER2_2}
end;
SetWideStringManager(CWideStringManager);
SetUnicodeStringManager(CWideStringManager);
end;
@ -752,3 +759,4 @@ finalization
{ fini conversion tables for main program }
FiniThread;
end.

1
rtl/win32/buildrtl.lpi
View File

@ -12,6 +12,7 @@
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=".exe"/>
<Title Value="buildrtl"/>
</General>

65
rtl/win32/system.pp
View File

@ -899,10 +899,6 @@ end;
{$endif Set_i386_Exception_handler}
{****************************************************************************
OS dependend widestrings
****************************************************************************}
const
{ MultiByteToWideChar }
MB_PRECOMPOSED = 1;
@ -918,6 +914,9 @@ function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD;
stdcall; external 'user32' name 'CharLowerBuffW';
{******************************************************************************
Widestring
******************************************************************************}
procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
var
@ -947,13 +946,57 @@ procedure Win32Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
function Win32WideUpper(const s : WideString) : WideString;
begin
result:=s;
UniqueString(result);
if length(result)>0 then
CharUpperBuff(LPWSTR(result),length(result));
end;
function Win32WideLower(const s : WideString) : WideString;
begin
result:=s;
if length(result)>0 then
CharLowerBuff(LPWSTR(result),length(result));
end;
{******************************************************************************
Unicode
******************************************************************************}
procedure Win32Unicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
var
destlen: SizeInt;
begin
// retrieve length including trailing #0
// not anymore, because this must also be usable for single characters
destlen:=WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil);
// this will null-terminate
setlength(dest, destlen);
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil);
end;
procedure Win32Ansi2UnicodeMove(source:pchar;var dest:UnicodeString;len:SizeInt);
var
destlen: SizeInt;
begin
// retrieve length including trailing #0
// not anymore, because this must also be usable for single characters
destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
// this will null-terminate
setlength(dest, destlen);
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
end;
function Win32UnicodeUpper(const s : UnicodeString) : UnicodeString;
begin
result:=s;
UniqueString(result);
if length(result)>0 then
CharUpperBuff(LPWSTR(result),length(result));
end;
function Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
begin
result:=s;
UniqueString(result);
@ -966,10 +1009,18 @@ function Win32WideLower(const s : WideString) : WideString;
are only relevant for the sysutils units }
procedure InitWin32Widestrings;
begin
{ Widestring }
widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
widestringmanager.UpperWideStringProc:=@Win32WideUpper;
widestringmanager.LowerWideStringProc:=@Win32WideLower;
{$ifndef VER2_2}
{ Unicode }
widestringmanager.Unicode2AnsiMoveProc:=@Win32Unicode2AnsiMove;
widestringmanager.Ansi2UnicodeMoveProc:=@Win32Ansi2UnicodeMove;
widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper;
widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower;
{$endif VER2_2}
end;
@ -1192,6 +1243,10 @@ begin
errno:=0;
initvariantmanager;
initwidestringmanager;
{$ifndef VER2_2}
initunicodestringmanager;
{$endif VER2_2}
InitWin32Widestrings;
DispCallByIDProc:=@DoDispCallByIDError;
end.

2
tests/test/trtti1.pp
View File

@ -11,7 +11,7 @@ Const TypeNames : Array [TTYpeKind] of string[15] =
'Float','Set','Method','ShortString','LongString',
'AnsiString','WideString','Variant','Array','Record',
'Interface','Class','Object','WideChar','Bool','Int64','QWord',
'DynamicArray','RawInterface');
'DynamicArray','RawInterface','ProcVar','UnicodeString','UnicodeChar');
Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool];

27
tests/test/tstring10.pp Normal file
View File

@ -0,0 +1,27 @@
program punicodechartest;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
{$ifdef mswindows}{$apptype console}{$endif}
uses
{$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}
sysutils;
var
astr: ansistring;
wstr: widestring;
ustr: unicodestring;
begin
astr:= '';
wstr:= '';
ustr:= '';
writeln(ptrint(pansichar(astr)));
flush(output);
writeln(ptrint(pwidechar(wstr)));
flush(output);
writeln(ptrint(punicodechar(ustr)));
flush(output);
writeln(ord(pansichar(astr)^));
flush(output);
writeln(ord(pwidechar(wstr)^));
flush(output);
writeln(ord(punicodechar(ustr)^));
flush(output);
end.

19
tests/test/tunistr1.pp Normal file
View File

@ -0,0 +1,19 @@
{$ifdef unix}
uses
cwstring;
{$endif unix}
var
w : unicodestring;
a : ansistring;
begin
a:='A';
w:=a;
if w[1]<>#65 then
halt(1);
a:=w;
if a[1]<>'A' then
halt(1);
writeln('ok');
end.

21
tests/test/tunistr2.pp Normal file
View File

@ -0,0 +1,21 @@
{$ifdef UNIX}
uses
cwstring;
{$endif UNIX}
var
i : longint;
w,w2 : unicodestring;
a : ansistring;
begin
setlength(w,1000);
for i:=1 to 1000 do
w[i]:=widechar(i);
for i:=1 to 10 do
begin
a:=w;
w2:=a;
end;
writeln('ok');
end.

92
tests/test/tunistr4.pp Normal file
View File

@ -0,0 +1,92 @@

{$ifdef fpc}
{$mode objfpc}
{$endif fpc}
uses
{$ifdef unix}
cthreads, cwstring,
{$endif}
Classes, SysUtils;
type
tc = class(tthread)
orgstr: ansistring;
cnvstr: unicodestring;
constructor create(const s: ansistring; const w: unicodestring);
procedure execute; override;
end;
const
// string with an invalid utf-8 code sequence
str1 = #$c1#$34'Życie'#$c1#$34' jest jak papier '#$c1#$34'toaletowy'#$c1#$34' : długie, szare i '#$c1#$34'do'#$c1#$34' dupy';
str2 = 'Życie '#$c1#$34'jest'#$c1#$34' jak papier toaletowy : '#$c1#$34'długie'#$c1#$34', szare i do '#$c1#$34'dupy'#$c1#$34'222222222222222222222222222222222222222222222222';
str3 = 'Życie jest '#$c1#$34'jak'#$c1#$34' papier 333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333 toaletowy : długie, '#$c1#$34'szare'#$c1#$34' i do dupy';
str4 = 'Życie jest 4444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444444 jak '#$c1#$34'papier'#$c1#$34' toaletowy : długie, szare '#$c1#$34'i'#$c1#$34' do dupy';
count = 20000;
var
wstr: unicodestring;
// cnvstr: ansistring;
error: boolean;
constructor tc.create(const s: ansistring; const w: unicodestring);
begin
orgstr:=s;
cnvstr:=w;
inherited create(true);
end;
procedure tc.execute;
var
i: longint;
w: unicodestring;
begin
for i := 1 to count do
begin
w:=orgstr;
if (w<>cnvstr) then
error:=true;
end;
end;
var
a: array[1..4] of tc;
w1,w2,w3,w4: unicodestring;
cnvstr: ansistring;
begin
error:=false;
cnvstr:=str1;
w1:=cnvstr;
cnvstr:=str2;
w2:=cnvstr;
cnvstr:=str3;
w3:=cnvstr;
cnvstr:=str4;
w4:=cnvstr;
writeln(w1);
writeln(w2);
writeln(w3);
writeln(w4);
a[1]:=tc.create(str1,w1);
a[2]:=tc.create(str2,w2);
a[3]:=tc.create(str3,w3);
a[4]:=tc.create(str4,w4);
a[1].resume;
a[2].resume;
a[3].resume;
a[4].resume;
a[1].waitfor;
a[2].waitfor;
a[3].waitfor;
a[4].waitfor;
a[1].free;
a[2].free;
a[3].free;
a[4].free;
if error then
halt(1);
end.

45
tests/test/tunistr5.pp Normal file
View File

@ -0,0 +1,45 @@
{$codepage utf-8}
var
ws: unicodestring;
us: UCS4String;
begin
// the compiler does not yet support characters which require
// a surrogate pair in utf-16
// ws:='鳣ćçŹ你';
// so write the last character directly using a utf-16 surrogate pair
ws:='鳣ćçŹ'#$d87e#$dc04;
if (length(ws)<>8) or
(ws[1]<>'é') or
(ws[2]<>'ł') or
(ws[3]<>'Ł') or
(ws[4]<>'ć') or
(ws[5]<>'ç') or
(ws[6]<>'Ź') or
(ws[7]<>#$d87e) or
(ws[8]<>#$dc04) then
halt(1);
us:=UnicodeStringToUCS4String(ws);
if (length(us)<>8) or
(us[0]<>UCS4Char(unicodechar('é'))) or
(us[1]<>UCS4Char(unicodechar('ł'))) or
(us[2]<>UCS4Char(unicodechar('Ł'))) or
(us[3]<>UCS4Char(unicodechar('ć'))) or
(us[4]<>UCS4Char(unicodechar('ç'))) or
(us[5]<>UCS4Char(unicodechar('Ź'))) or
(us[6]<>UCS4Char($2F804)) or
(us[7]<>UCS4Char(0)) then
halt(2);
ws:=UCS4StringToUnicodeString(us);
if (length(ws)<>8) or
(ws[1]<>'é') or
(ws[2]<>'ł') or
(ws[3]<>'Ł') or
(ws[4]<>'ć') or
(ws[5]<>'ç') or
(ws[6]<>'Ź') or
(ws[7]<>#$d87e) or
(ws[8]<>#$dc04) then
halt(3);
end.

397
tests/test/tunistr6.pp Normal file
View File

@ -0,0 +1,397 @@
{%skiptarget=wince}
{$codepage utf-8}
uses
{$ifdef unix}
cwstring,
{$endif}
sysutils;
procedure doerror(i : integer);
begin
writeln('Error: ',i);
halt(i);
end;
{ normal upper case testing }
procedure testupper;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
w1:='aé'#0'èàł'#$d87e#$dc04;
w2:='AÉ'#0'ÈÀŁ'#$d87e#$dc04;
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original upper: ',w2);
{$endif print}
s:=w1;
{$ifdef print}
writeln('ansi: ',s);
{$endif print}
w3:=s;
w4:=AnsiUpperCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeUpperCase(w1);
{$ifdef print}
writeln('unicodeupper: ',w1);
writeln('original upper: ',w2);
writeln('ansiupper: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(1);
if (w4 <> w2) then
doerror(2);
w1:='aéèàł'#$d87e#$dc04;
w2:='AÉÈÀŁ'#$d87e#$dc04;
s:=w1;
w3:=s;
w4:=AnsiStrUpper(pchar(s));
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeUpperCase(w1);
{$ifdef print}
writeln('unicodeupper: ',w1);
writeln('ansistrupper: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(21);
if (w4 <> w2) then
doerror(22);
end;
{ normal lower case testing }
procedure testlower;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
w1:='AÉ'#0'ÈÀŁ'#$d87e#$dc04;
w2:='aé'#0'èàł'#$d87e#$dc04;
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original lower: ',w2);
{$endif print}
s:=w1;
w3:=s;
w4:=AnsiLowerCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeLowerCase(w1);
{$ifdef print}
writeln('unicodelower: ',w1);
writeln('ansilower: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(3);
if (w4 <> w2) then
doerror(4);
w1:='AÉÈÀŁ'#$d87e#$dc04;
w2:='aéèàł'#$d87e#$dc04;
s:=w1;
w3:=s;
w4:=AnsiStrLower(pchar(s));
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeLowerCase(w1);
{$ifdef print}
writeln('unicodelower: ',w1);
writeln('ansistrlower: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(3);
if (w4 <> w2) then
doerror(4);
end;
{ upper case testing with a missing utf-16 pair at the end }
procedure testupperinvalid;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
{ missing utf-16 pair at end }
w1:='aé'#0'èàł'#$d87e;
w2:='AÉ'#0'ÈÀŁ'#$d87e;
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original upper: ',w2);
{$endif print}
s:=w1;
w3:=s;
w4:=AnsiUpperCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeUpperCase(w1);
{$ifdef print}
writeln('unicodeupper: ',w1);
writeln('ansiupper: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(5);
if (w4 <> w2) then
doerror(6);
end;
{ lower case testing with a missing utf-16 pair at the end }
procedure testlowerinvalid;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
{ missing utf-16 pair at end}
w1:='AÉ'#0'ÈÀŁ'#$d87e;
w2:='aé'#0'èàł'#$d87e;
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original lower: ',w2);
{$endif print}
s:=w1;
w3:=s;
w4:=AnsiLowerCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeLowerCase(w1);
{$ifdef print}
writeln('unicodelower: ',w1);
writeln('ansilower: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(7);
if (w4 <> w2) then
doerror(8);
end;
{ upper case testing with a missing utf-16 pair at the end, followed by a normal char }
procedure testupperinvalid1;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
{ missing utf-16 pair at end with char after it}
w1:='aé'#0'èàł'#$d87e'j';
w2:='AÉ'#0'ÈÀŁ'#$d87e'J';
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original upper: ',w2);
{$endif print}
s:=w1;
w3:=s;
w4:=AnsiUpperCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeUpperCase(w1);
{$ifdef print}
writeln('unicodeupper: ',w1);
writeln('ansiupper: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(9);
if (w4 <> w2) then
doerror(10);
end;
{ lower case testing with a missing utf-16 pair at the end, followed by a normal char }
procedure testlowerinvalid1;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
{ missing utf-16 pair at end with char after it}
w1:='AÉ'#0'ÈÀŁ'#$d87e'J';
w2:='aé'#0'èàł'#$d87e'j';
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original lower: ',w2);
{$endif print}
s:=w1;
w3:=s;
w4:=AnsiLowerCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeLowerCase(w1);
{$ifdef print}
writeln('unicodelower: ',w1);
writeln('ansilower: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(11);
if (w4 <> w2) then
doerror(12);
end;
{ upper case testing with corrupting the utf-8 string after conversion }
procedure testupperinvalid2;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
w1:='aé'#0'èàł'#$d87e#$dc04'ö';
w2:='AÉ'#0'ÈÀŁ'#$d87e#$dc04'Ö';
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original upper: ',w2);
{$endif print}
s:=w1;
{ truncate the last utf-8 character }
setlength(s,length(s)-1);
w3:=s;
{ adjust checking values for new length due to corruption }
if length(w3)<>length(w2) then
begin
setlength(w2,length(w3));
setlength(w1,length(w3));
end;
w4:=AnsiUpperCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeUpperCase(w1);
{$ifdef print}
writeln('unicodeupper: ',w1);
writeln('ansiupper: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(13);
if (w4 <> w2) then
doerror(14);
end;
{ lower case testing with corrupting the utf-8 string after conversion }
procedure testlowerinvalid2;
var
s: ansistring;
w1,w2,w3,w4: unicodestring;
i: longint;
begin
w1:='AÉ'#0'ÈÀŁ'#$d87e#$dc04'Ö';
w2:='aé'#0'èàł'#$d87e#$dc04'ö';
{$ifdef print}
// the utf-8 output can confuse the testsuite parser
writeln('original: ',w1);
writeln('original lower: ',w2);
{$endif print}
s:=w1;
{ truncate the last utf-8 character }
setlength(s,length(s)-1);
w3:=s;
{ adjust checking values for new length due to corruption }
if length(w3)<>length(w2) then
begin
setlength(w2,length(w3));
setlength(w1,length(w3));
end;
w4:=AnsiLowerCase(s);
{ filter out unsupported characters }
for i:=1 to length(w3) do
if w3[i]='?' then
begin
w2[i]:='?';
w1[i]:='?';
end;
w1:=UnicodeLowerCase(w1);
{$ifdef print}
writeln('unicodelower: ',w1);
writeln('ansilower: ',w4);
{$endif print}
if (w1 <> w2) then
doerror(15);
if (w4 <> w2) then
doerror(16);
end;
begin
testupper;
writeln;
testlower;
writeln;
writeln;
testupperinvalid;
writeln;
testlowerinvalid;
writeln;
writeln;
testupperinvalid1;
writeln;
testlowerinvalid1;
writeln;
writeln;
testupperinvalid2;
writeln;
testlowerinvalid2;
writeln('ok');
end.

47
tests/test/tunistr7.pp Normal file
View File

@ -0,0 +1,47 @@
{$codepage utf-8}
uses
{$ifdef unix}
cwstring,
{$endif unix}
sysutils;
procedure testwcmp;
var
w1,w2: unicodestring;
s: ansistring;
begin
w1:='aécde';
{ filter unsupported characters }
s:=w1;
w1:=s;
w2:=w1;
if (w1<>w2) then
halt(1);
w1[2]:='f';
if (w1=w2) or
WideSameStr(w1,w2) or
(WideCompareText(w1,w2)=0) or
(WideCompareStr(w1,w2)<0) or
(WideCompareStr(w2,w1)>0) then
halt(2);
w1[2]:=#0;
w2[2]:=#0;
if (w1<>w2) or
not WideSameStr(w1,w2) or
(WideCompareStr(w1,w2)<>0) or
(WideCompareText(w1,w2)<>0) then
halt(3);
w1[3]:='m';
if WideSameStr(w1,w2) or
(WideCompareText(w1,w2)=0) or
(WideCompareStr(w1,w2)<0) or
(WideCompareStr(w2,w1)>0) then
halt(4);
end;
begin
testwcmp;
end.