mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2026-02-04 08:14:51 +01:00
b178b08ba7
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 -
398 lines
8.1 KiB
ObjectPascal
398 lines
8.1 KiB
ObjectPascal
{%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.
|