29 |
(* *) |
(* *) |
30 |
(**********************************************************************************) |
(**********************************************************************************) |
31 |
|
|
32 |
|
type uchar = int |
33 |
|
|
34 |
type charset = |
type charset = |
35 |
| ANSI_X3_4_1968 | ANSI_X3_4_1986 | ASCII | CP367 | IBM367 | ISO_IR_6 | ISO646_US | ISO_646_IRV_1991 | US | US_ASCII | CSASCII |
| ANSI_X3_4_1968 | ANSI_X3_4_1986 | ASCII | CP367 | IBM367 | ISO_IR_6 | ISO646_US | ISO_646_IRV_1991 | US | US_ASCII | CSASCII |
36 |
| UTF_8 |
| UTF_8 |
167 |
|
|
168 |
(**********************************************************************************) |
(**********************************************************************************) |
169 |
(* *) |
(* *) |
170 |
|
(* utf8_get *) |
171 |
|
(* *) |
172 |
|
(**********************************************************************************) |
173 |
|
|
174 |
|
(* taken from camomile *) |
175 |
|
(* $Id$ *) |
176 |
|
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *) |
177 |
|
|
178 |
|
let utf8_look s i = |
179 |
|
let n' = |
180 |
|
let n = Char.code s.[i] in |
181 |
|
if n < 0x80 then n else |
182 |
|
if n <= 0xdf then |
183 |
|
(n - 0xc0) lsl 6 lor (0x7f land (Char.code s.[i + 1])) |
184 |
|
else if n <= 0xef then |
185 |
|
let n' = n - 0xe0 in |
186 |
|
let m0 = Char.code s.[i + 2] in |
187 |
|
let m = Char.code (String.unsafe_get s (i + 1)) in |
188 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
189 |
|
n' lsl 6 lor (0x7f land m0) |
190 |
|
else if n <= 0xf7 then |
191 |
|
let n' = n - 0xf0 in |
192 |
|
let m0 = Char.code s.[i + 3] in |
193 |
|
let m = Char.code (String.unsafe_get s (i + 1)) in |
194 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
195 |
|
let m = Char.code (String.unsafe_get s (i + 2)) in |
196 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
197 |
|
n' lsl 6 lor (0x7f land m0) |
198 |
|
else if n <= 0xfb then |
199 |
|
let n' = n - 0xf8 in |
200 |
|
let m0 = Char.code s.[i + 4] in |
201 |
|
let m = Char.code (String.unsafe_get s (i + 1)) in |
202 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
203 |
|
let m = Char.code (String.unsafe_get s (i + 2)) in |
204 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
205 |
|
let m = Char.code (String.unsafe_get s (i + 3)) in |
206 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
207 |
|
n' lsl 6 lor (0x7f land m0) |
208 |
|
else if n <= 0xfd then |
209 |
|
let n' = n - 0xfc in |
210 |
|
let m0 = Char.code s.[i + 5] in |
211 |
|
let m = Char.code (String.unsafe_get s (i + 1)) in |
212 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
213 |
|
let m = Char.code (String.unsafe_get s (i + 2)) in |
214 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
215 |
|
let m = Char.code (String.unsafe_get s (i + 3)) in |
216 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
217 |
|
let m = Char.code (String.unsafe_get s (i + 4)) in |
218 |
|
let n' = n' lsl 6 lor (0x7f land m) in |
219 |
|
n' lsl 6 lor (0x7f land m0) |
220 |
|
else invalid_arg "utf8_look" |
221 |
|
in |
222 |
|
if n' lsr 31 = 0 then n' else |
223 |
|
invalid_arg "utf8_look char_of_uint" |
224 |
|
|
225 |
|
let rec search_head s i = |
226 |
|
if i >= String.length s then i else |
227 |
|
let n = Char.code (String.unsafe_get s i) in |
228 |
|
if n < 0x80 || n >= 0xc2 then i else |
229 |
|
search_head s (i + 1) |
230 |
|
|
231 |
|
let utf8_next s i = |
232 |
|
let n = Char.code s.[i] in |
233 |
|
if n < 0x80 then i + 1 else |
234 |
|
if n < 0xc0 then search_head s (i + 1) else |
235 |
|
if n <= 0xdf then i + 2 |
236 |
|
else if n <= 0xef then i + 3 |
237 |
|
else if n <= 0xf7 then i + 4 |
238 |
|
else if n <= 0xfb then i + 5 |
239 |
|
else if n <= 0xfd then i + 6 |
240 |
|
else invalid_arg "utf8_next" |
241 |
|
|
242 |
|
let rec nth_aux s i n = |
243 |
|
if n = 0 then i else |
244 |
|
nth_aux s (utf8_next s i) (n - 1) |
245 |
|
|
246 |
|
let nth s n = nth_aux s 0 n |
247 |
|
|
248 |
|
let utf8_get s n = utf8_look s (nth s n) |
249 |
|
|
250 |
|
(**********************************************************************************) |
251 |
|
(* *) |
252 |
|
(* utf8_length *) |
253 |
|
(* *) |
254 |
|
(**********************************************************************************) |
255 |
|
|
256 |
|
(* taken from camomile *) |
257 |
|
(* $Id$ *) |
258 |
|
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *) |
259 |
|
|
260 |
|
let rec length_aux s c i = |
261 |
|
if i >= String.length s then c else |
262 |
|
let n = Char.code (String.unsafe_get s i) in |
263 |
|
let k = |
264 |
|
if n < 0x80 then 1 else |
265 |
|
if n < 0xc0 then invalid_arg "UTF8.length" else |
266 |
|
if n < 0xe0 then 2 else |
267 |
|
if n < 0xf0 then 3 else |
268 |
|
if n < 0xf8 then 4 else |
269 |
|
if n < 0xfc then 5 else |
270 |
|
if n < 0xfe then 6 else |
271 |
|
invalid_arg "UTF8.length" in |
272 |
|
length_aux s (c + 1) (i + k) |
273 |
|
|
274 |
|
let utf8_length s = length_aux s 0 0 |
275 |
|
|
276 |
|
(**********************************************************************************) |
277 |
|
(* *) |
278 |
|
(* add_uchar (internal) *) |
279 |
|
(* *) |
280 |
|
(**********************************************************************************) |
281 |
|
|
282 |
|
|
283 |
|
(* taken from camomile *) |
284 |
|
(* $Id$ *) |
285 |
|
(* Copyright 2002, 2003 Yamagata Yoriyuki. distributed with LGPL *) |
286 |
|
|
287 |
|
external uint_code : uchar -> int = "%identity" |
288 |
|
|
289 |
|
let add_uchar buf u = |
290 |
|
let masq = 0b111111 in |
291 |
|
let k = uint_code u in |
292 |
|
if k < 0 || k >= 0x4000000 then begin |
293 |
|
Buffer.add_char buf (Char.chr (0xfc + (k lsr 30))); |
294 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 24) land masq))); |
295 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq))); |
296 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); |
297 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); |
298 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); |
299 |
|
end else if k <= 0x7f then |
300 |
|
Buffer.add_char buf (Char.unsafe_chr k) |
301 |
|
else if k <= 0x7ff then begin |
302 |
|
Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6))); |
303 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))) |
304 |
|
end else if k <= 0xffff then begin |
305 |
|
Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12))); |
306 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); |
307 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); |
308 |
|
end else if k <= 0x1fffff then begin |
309 |
|
Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18))); |
310 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); |
311 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); |
312 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); |
313 |
|
end else begin |
314 |
|
Buffer.add_char buf (Char.unsafe_chr (0xf8 + (k lsr 24))); |
315 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq))); |
316 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq))); |
317 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq))); |
318 |
|
Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq))); |
319 |
|
end |
320 |
|
|
321 |
|
(**********************************************************************************) |
322 |
|
(* *) |
323 |
(* charset_to_string *) |
(* charset_to_string *) |
324 |
(* *) |
(* *) |
325 |
(**********************************************************************************) |
(**********************************************************************************) |
1648 |
with _ -> ASCII |
with _ -> ASCII |
1649 |
|
|
1650 |
let locstr = |
let locstr = |
1651 |
|
Printf.printf "Blocking system signals until core is started...\n"; |
1652 |
|
(* block signals until core started correctly *) |
1653 |
|
(MlUnix.set_signal Sys.sigint |
1654 |
|
(Sys.Signal_handle (fun _ -> ()))); |
1655 |
|
(MlUnix.set_signal Sys.sigterm |
1656 |
|
(Sys.Signal_handle (fun _ -> ()))); |
1657 |
|
|
1658 |
let s = charset_to_string locale in |
let s = charset_to_string locale in |
1659 |
Printf.printf "Current locale of the target machine is %s\n" s; |
Printf.printf "Current locale of the target machine is %s\n" s; |
1660 |
flush stdout; |
flush stdout; |
1818 |
|
|
1819 |
(**********************************************************************************) |
(**********************************************************************************) |
1820 |
(* *) |
(* *) |
1821 |
(* slow_encode *) |
(* slow_encode_from_utf8 *) |
1822 |
(* *) |
(* *) |
1823 |
(**********************************************************************************) |
(**********************************************************************************) |
1824 |
|
|
1825 |
let slow_encode s to_codeset = |
let slow_encode_from_utf8 s to_codeset = |
1826 |
let us = ref "" in |
let us = ref "" in |
1827 |
let slen = String.length s in |
let slen = utf8_length s in |
1828 |
|
let buf = Buffer.create 10 in |
1829 |
for i = 0 to (slen - 1) do |
for i = 0 to (slen - 1) do |
1830 |
try |
try |
1831 |
us := !us ^ (convert_string (String.sub s i 1) to_codeset locstr) |
let uchar = utf8_get s i in |
1832 |
|
add_uchar buf uchar; |
1833 |
|
let s' = Buffer.contents buf in |
1834 |
|
Buffer.reset buf; |
1835 |
|
let s' = convert_string s' to_codeset "UTF-8" in |
1836 |
|
us := !us ^ s' |
1837 |
with _ -> |
with _ -> |
1838 |
us := !us ^ char_const |
us := !us ^ char_const |
1839 |
done; |
done; |
1841 |
|
|
1842 |
(**********************************************************************************) |
(**********************************************************************************) |
1843 |
(* *) |
(* *) |
1844 |
|
(* slow_encode *) |
1845 |
|
(* *) |
1846 |
|
(**********************************************************************************) |
1847 |
|
|
1848 |
|
let slow_encode s to_codeset = |
1849 |
|
if is_utf8 s |
1850 |
|
then slow_encode_from_utf8 s to_codeset |
1851 |
|
else begin |
1852 |
|
let us = ref "" in |
1853 |
|
let slen = String.length s in |
1854 |
|
for i = 0 to (slen - 1) do |
1855 |
|
try |
1856 |
|
us := !us ^ (convert_string (String.sub s i 1) to_codeset locstr) |
1857 |
|
with _ -> |
1858 |
|
us := !us ^ char_const |
1859 |
|
done; |
1860 |
|
!us |
1861 |
|
end |
1862 |
|
|
1863 |
|
(**********************************************************************************) |
1864 |
|
(* *) |
1865 |
(* fast_encode *) |
(* fast_encode *) |
1866 |
(* *) |
(* *) |
1867 |
(**********************************************************************************) |
(**********************************************************************************) |
1908 |
try |
try |
1909 |
convert_string s locstr "UTF-8" |
convert_string s locstr "UTF-8" |
1910 |
with _ -> |
with _ -> |
1911 |
begin |
slow_encode_from_utf8 s locstr |
|
let us = ref "" in |
|
|
let slen = String.length s in |
|
|
for i = 0 to (slen - 1) do |
|
|
try |
|
|
us := !us ^ (convert_string (String.sub s i 1) locstr "UTF-8") |
|
|
with _ -> |
|
|
us := !us ^ char_const |
|
|
done; |
|
|
!us |
|
|
end |
|
1912 |
end |
end |
1913 |
end |
end |
1914 |
|
|
|
|
|
1915 |
let _ = |
let _ = |
1916 |
set_default_charset_list default_language |
set_default_charset_list default_language |