1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
| unit UTF8ToWideString_TestForm;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function UTF8ToWideString(const S: AnsiString): WideString; forward;
function UTF8Decode_Klaus(const as8: AnsiString): WideString; forward;
procedure TForm1.Button1Click(Sender: TObject);
function HexaConvert(s: string): AnsiString;
var
s1: string;
i, n, c: integer;
begin
n := Length(s);
setLength(Result, trunc(n/3));
for i:=1 to trunc(n/3) do begin
s1 := Copy(s,i*3-2,2);
c := StrToInt('$'+s1);
result[i] := AnsiChar(c);
end;
end;
var
s: string;
utf8string: AnsiString;
begin
s := 'E4 BB 8E E4 B8 AD E5 9B BD E6 9D A5 E7 9A 84 E7 AC AC E4 B8 80 E5 B0 81 E4 BF A1 E0 AB B9 F0 90 80 A4 ';
utf8string := HexaConvert(s);
ShowMessage(UTF8Decode(utf8string) + sLineBreak + UTF8ToWideString(utf8string) + sLineBreak + UTF8Decode_Klaus(utf8string));
s := 'E4 BB 8E E4 B8 AD E5 9B BD E6 9D A5 E7 9A 84 E7 AC AC E4 B8 80 E5 B0 81 E4 BF A1 E0 AB B9 F0 A0 80 A4 ';
utf8string := HexaConvert(s);
ShowMessage(UTF8Decode(utf8string) + sLineBreak + UTF8ToWideString(utf8string) + sLineBreak + UTF8Decode_Klaus(utf8string));
end;
function UTF8ToWideString(const S: AnsiString): WideString;
var
P: PByte;
C: Byte;
CodePoint: Cardinal;
K: Integer;
begin
Result := '';
if S = '' then
Exit;
SetLength(Result, Length(S));
K := 0;
P := PByte(@S[1]);
CodePoint := 0;
while P^ <> 0 do
begin
C := P^;
if C <= $7F then
CodePoint := C
else if C <= $BF then
CodePoint := (CodePoint shl 6) or (C and $3F)
else if C <= $DF then
CodePoint := C and $1F
else if C <= $EF then
CodePoint := C and $0F
else
CodePoint := C and $07;
Inc(P);
if ((P^ and $C0) <> $80) and (CodePoint <= $10FFFF) then
begin
if CodePoint > $FFFF then
begin
Dec(CodePoint, $10000);
Inc(K);
Result[K] := WideChar($D800 or ((CodePoint shr 10) and $03FF));
Inc(K);
Result[K] := WideChar($DC00 or (CodePoint and $3FF));
end
else if (CodePoint < $D800) or (CodePoint >= $E000) then
begin
Inc(K);
Result[K] := WideChar(CodePoint);
end;
end;
end;
SetLength(Result, K);
end;
function UTF8Decode_Klaus(const as8: AnsiString): WideString;
var
B: array of byte;
i: integer;
c, c1, c2, cnt: integer;
pb, pb1, pb2, pb3: pByte;
pw: pWideChar;
ok: boolean;
procedure IncrementBP(Increment: integer);
begin
inc(pb,Increment);
inc(pb1,Increment);
inc(pb2,Increment);
inc(pb3,Increment);
i := i + Increment;
end;
{
# Bytes First code point Last code point Byte 1 Byte 2 Byte 3 Byte 4
1 U+0000 U+007F 0yyyzzzz
2 U+0080 U+07FF 110xxxyy 10yyzzzz
3 U+0800 U+FFFF 1110wwww 10xxxxyy 10yyzzzz
4 U+010000 U+10FFFF 11110uvv 10vvwwww 10xxxxyy 10yyzzzz
}
begin
SetLength(B,Length(as8));
SetLength(result,length(as8));
cnt := 0;
pw := PWideChar(@result[1]);
for i:=1 to Length(as8) do B[i-1] := Ord(as8[i]);
pb := pByte(@B[0]);
pb1 := pByte(@B[1]);
pb2 := pByte(@B[2]);
pb3 := pByte(@B[3]);
{
1 E4
2 B8
3 AD
}
i := 0;
while i<Length(as8) do begin
ok := false;
//showmessage('A: '+inttostr(i)+': '+inttohex(integer(pb^),2));
{
# Bytes First code point Last code point Byte 1 Byte 2 Byte 3 Byte 4
1 U+0000 U+007F 0yyyzzzz
2 U+0080 U+07FF 110xxxyy 10yyzzzz
3 U+0800 U+FFFF 1110wwww 10xxxxyy 10yyzzzz
4 U+010000 U+10FFFF 11110uvv 10vvwwww 10xxxxyy 10yyzzzz
}
if (pb^ and $80)=0 then begin
cnt := cnt + 1;
result[cnt] := WideChar(pb^);
IncrementBP(1);
ok := true;
end else begin
//showmessage('B: '+inttostr(i)+': '+inttohex(integer(pb^),2));
if (pb^ and $E0)=$C0 then begin
//showmessage('C: '+inttostr(i)+': '+inttohex(integer(pb^),2));
c := ((pb^ and $1F) shl 6) or (pb1^and $3F);
cnt := cnt + 1;
result[cnt] := WideChar(c);
IncrementBP(2);
ok := true;
end else begin
//showmessage('D: '+inttostr(i)+': '+inttohex(integer(pb^),2)+' '+inttohex(integer(pb^) and $E0,2));
if (pb^ and $F0)=$E0 then begin
//showmessage('E: '+inttostr(i)+': '+inttohex(integer(pb^),2));
c := ((pb^ and $F) shl 12) or ((pb1^ and $3F) shl 6) or (pb2^ and $3F);
cnt := cnt + 1;
result[cnt] := WideChar(c);
IncrementBP(3);
ok := true;
end else begin
//showmessage('F: '+inttostr(i)+': '+inttohex(integer(pb^),2));
if (pb^ and $F0)=$F0 then begin
//showmessage('G: '+inttostr(i)+': '+inttohex(integer(pb^),2));
c := ((pb^ and $7) shl 18) or ((pb1^ and $3F) shl 12) or ((pb2^ and $3F) shl 6) or (pb3^ and $3F);
c := c - $10000;
c1 := $D800 or ((c shr 10) and $3FF);
c2 := $DC00 or (c and $3FF);
cnt := cnt + 1;
result[cnt] := WideChar(c1);
cnt := cnt + 1;
result[cnt] := WideChar(c2);
IncrementBP(4);
ok := true;
end;
end;
end;
end;
if not ok then begin
showmessage('UTF8 error at '+inttostr(integer(pb)-integer(@B[0]))+' ('+inttohex(integer(pb1^),2)+'): '+as8);
SetLength(result,cnt);
exit;
end;
end;
SetLength(result,cnt);
end;
end. |
La fonction UTF8Decode de Delphi 6 PE est incomplète ou a un gros bug !
Répondre avec citation
Partager