/[mldonkey]/mldonkey/src/utils/lib/charset.ml
ViewVC logotype

Diff of /mldonkey/src/utils/lib/charset.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by spiralvoice, Wed Apr 13 21:52:27 2005 UTC revision 1.3 by spiralvoice, Mon May 30 21:02:56 2005 UTC
# Line 29  Line 29 
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
# Line 165  external is_utf8 : string -> bool = "ml_ Line 167  external is_utf8 : string -> bool = "ml_
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  (**********************************************************************************)  (**********************************************************************************)
# Line 1493  let locale = Line 1648  let locale =
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;
# Line 1656  let convert ~from_charset ~to_charset s Line 1818  let convert ~from_charset ~to_charset s
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;
# Line 1673  let slow_encode s to_codeset = Line 1841  let slow_encode s to_codeset =
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  (**********************************************************************************)  (**********************************************************************************)
# Line 1719  let to_locale s = Line 1908  let to_locale s =
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

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26