+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- *)
-
-exception Malformed_code
-
-
-type encoding =
- [ `Enc_utf8 (* UTF-8 *)
- | `Enc_java
- | `Enc_utf16 (* UTF-16 with unspecified endianess (restricted usage) *)
- | `Enc_utf16_le (* UTF-16 little endian *)
- | `Enc_utf16_be (* UTF-16 big endian *)
- | `Enc_usascii (* US-ASCII (only 7 bit) *)
- | `Enc_iso88591 (* ISO-8859-1 *)
- | `Enc_iso88592 (* ISO-8859-2 *)
- | `Enc_iso88593 (* ISO-8859-3 *)
- | `Enc_iso88594 (* ISO-8859-4 *)
- | `Enc_iso88595 (* ISO-8859-5 *)
- | `Enc_iso88596 (* ISO-8859-6 *)
- | `Enc_iso88597 (* ISO-8859-7 *)
- | `Enc_iso88598 (* ISO-8859-8 *)
- | `Enc_iso88599 (* ISO-8859-9 *)
- | `Enc_iso885910 (* ISO-8859-10 *)
- | `Enc_iso885913 (* ISO-8859-13 *)
- | `Enc_iso885914 (* ISO-8859-14 *)
- | `Enc_iso885915 (* ISO-8859-15 *)
- | `Enc_koi8r (* KOI8-R *)
- | `Enc_jis0201 (* JIS-0201 *)
- (* Microsoft: *)
- | `Enc_windows1250 (* WINDOWS-1250 *)
- | `Enc_windows1251 (* WINDOWS-1251 *)
- | `Enc_windows1252 (* WINDOWS-1252 *)
- | `Enc_windows1253 (* WINDOWS-1253 *)
- | `Enc_windows1254 (* WINDOWS-1254 *)
- | `Enc_windows1255 (* WINDOWS-1255 *)
- | `Enc_windows1256 (* WINDOWS-1256 *)
- | `Enc_windows1257 (* WINDOWS-1257 *)
- | `Enc_windows1258 (* WINDOWS-1258 *)
- (* IBM, ASCII-based: *)
- | `Enc_cp437
- | `Enc_cp737
- | `Enc_cp775
- | `Enc_cp850
- | `Enc_cp852
- | `Enc_cp855
- | `Enc_cp856
- | `Enc_cp857
- | `Enc_cp860
- | `Enc_cp861
- | `Enc_cp862
- | `Enc_cp863
- | `Enc_cp864
- | `Enc_cp865
- | `Enc_cp866
- | `Enc_cp869
- | `Enc_cp874
- | `Enc_cp1006
- (* IBM, EBCDIC-based: *)
- | `Enc_cp037
- | `Enc_cp424
- | `Enc_cp500
- | `Enc_cp875
- | `Enc_cp1026
- (* Adobe: *)
- | `Enc_adobe_standard_encoding
- | `Enc_adobe_symbol_encoding
- | `Enc_adobe_zapf_dingbats_encoding
- (* Apple: *)
- | `Enc_macroman
-
- ]
-;;
-
-
-let norm_enc_name e =
- (* Removes some characters from e; uppercase *)
- let e' = String.create (String.length e) in
- let rec next i j =
- if i < String.length e then
- match e.[i] with
- ('-'|'_'|'.') -> next (i+1) j
- | c -> e'.[j] <- c; next (i+1) (j+1)
- else
- j
- in
- let l = next 0 0 in
- String.uppercase(String.sub e' 0 l)
-;;
-
-
-let encoding_of_string e =
- match norm_enc_name e with
- ("UTF16"|"UCS2"|"ISO10646UCS2") -> `Enc_utf16
- | "UTF16BE" -> `Enc_utf16_be
- | "UTF16LE" -> `Enc_utf16_le
- | "UTF8" -> `Enc_utf8
- | ("UTF8JAVA"|"JAVA") -> `Enc_java
- | ("USASCII"|"ASCII"|"ISO646US"|"IBM367"|"CP367") -> `Enc_usascii
- | ("ISO88591"|"LATIN1"|"IBM819"|"CP819") -> `Enc_iso88591
- | ("ISO88592"|"LATIN2") -> `Enc_iso88592
- | ("ISO88593"|"LATIN3") -> `Enc_iso88593
- | ("ISO88594"|"LATIN4") -> `Enc_iso88594
- | ("ISO88595"|"CYRILLIC") -> `Enc_iso88595
- | ("ISO88596"|"ARABIC"|"ECMA114"|"ASMO708") -> `Enc_iso88596
- | ("ISO88597"|"GREEK"|"GREEK8"|"ELOT928"|"ECMA118") -> `Enc_iso88597
- | ("ISO88598"|"HEBREW") -> `Enc_iso88598
- | ("ISO88599"|"LATIN5") -> `Enc_iso88599
- | ("ISO885910"|"LATIN6") -> `Enc_iso885910
- | "ISO885913" -> `Enc_iso885913
- | "ISO885914" -> `Enc_iso885914
- | "ISO885915" -> `Enc_iso885915
- | "KOI8R" -> `Enc_koi8r
- | ("JIS0201"|"JISX0201"|"X0201") -> `Enc_jis0201
-
- | "WINDOWS1250" -> `Enc_windows1250
- | "WINDOWS1251" -> `Enc_windows1251
- | "WINDOWS1252" -> `Enc_windows1252
- | "WINDOWS1253" -> `Enc_windows1253
- | "WINDOWS1254" -> `Enc_windows1254
- | "WINDOWS1255" -> `Enc_windows1255
- | "WINDOWS1256" -> `Enc_windows1256
- | "WINDOWS1257" -> `Enc_windows1257
- | "WINDOWS1258" -> `Enc_windows1258
-
- | ("CP437"|"IBM437") -> `Enc_cp437
- | ("CP737"|"IBM737") -> `Enc_cp737
- | ("CP775"|"IBM775") -> `Enc_cp775
- | ("CP850"|"IBM850") -> `Enc_cp850
- | ("CP852"|"IBM852") -> `Enc_cp852
- | ("CP855"|"IBM855") -> `Enc_cp855
- | ("CP856"|"IBM856") -> `Enc_cp856
- | ("CP857"|"IBM857") -> `Enc_cp857
- | ("CP860"|"IBM860") -> `Enc_cp860
- | ("CP861"|"IBM861") -> `Enc_cp861
- | ("CP862"|"IBM862") -> `Enc_cp862
- | ("CP863"|"IBM863") -> `Enc_cp863
- | ("CP864"|"IBM864") -> `Enc_cp864
- | ("CP865"|"IBM865") -> `Enc_cp865
- | ("CP866"|"IBM866") -> `Enc_cp866
- | ("CP869"|"IBM869") -> `Enc_cp869
- | ("CP874"|"IBM874") -> `Enc_cp874
- | ("CP1006"|"IBM1006") -> `Enc_cp1006
-
- | ("CP037"|"IBM037"|"EBCDICCPUS"|"EBCDICCPCA"|"EBCDICCPWT"|
- "EBCDICCPNL") -> `Enc_cp037
- | ("CP424"|"IBM424"|"EBCDICCPHE") -> `Enc_cp424
- | ("CP500"|"IBM500"|"EBCDICCPBE"|"EBCDICCPCH") -> `Enc_cp500
- | ("CP875"|"IBM875") -> `Enc_cp875
- | ("CP1026"|"IBM1026") -> `Enc_cp1026
-
- | "ADOBESTANDARDENCODING" -> `Enc_adobe_standard_encoding
- | "ADOBESYMBOLENCODING" -> `Enc_adobe_symbol_encoding
- | "ADOBEZAPFDINGBATSENCODING" -> `Enc_adobe_zapf_dingbats_encoding
-
- | "MACINTOSH" -> `Enc_macroman
-
- | _ ->
- failwith "Netconversion.encoding_of_string: unknown encoding"
-;;
-
-
-let string_of_encoding (e : encoding) =
- (* If there is a "preferred MIME name", this name is returned (see IANA). *)
- match e with
- `Enc_utf16 -> "UTF-16"
- | `Enc_utf16_be -> "UTF-16-BE"
- | `Enc_utf16_le -> "UTF-16-LE"
- | `Enc_utf8 -> "UTF-8"
- | `Enc_java -> "UTF-8-JAVA"
- | `Enc_usascii -> "US-ASCII"
- | `Enc_iso88591 -> "ISO-8859-1"
- | `Enc_iso88592 -> "ISO-8859-2"
- | `Enc_iso88593 -> "ISO-8859-3"
- | `Enc_iso88594 -> "ISO-8859-4"
- | `Enc_iso88595 -> "ISO-8859-5"
- | `Enc_iso88596 -> "ISO-8859-6"
- | `Enc_iso88597 -> "ISO-8859-7"
- | `Enc_iso88598 -> "ISO-8859-8"
- | `Enc_iso88599 -> "ISO-8859-9"
- | `Enc_iso885910 -> "ISO-8859-10"
- | `Enc_iso885913 -> "ISO-8859-13"
- | `Enc_iso885914 -> "ISO-8859-14"
- | `Enc_iso885915 -> "ISO-8859-15"
- | `Enc_koi8r -> "KOI8-R"
- | `Enc_jis0201 -> "JIS_X0201"
- | `Enc_windows1250 -> "WINDOWS-1250"
- | `Enc_windows1251 -> "WINDOWS-1251"
- | `Enc_windows1252 -> "WINDOWS-1252"
- | `Enc_windows1253 -> "WINDOWS-1253"
- | `Enc_windows1254 -> "WINDOWS-1254"
- | `Enc_windows1255 -> "WINDOWS-1255"
- | `Enc_windows1256 -> "WINDOWS-1256"
- | `Enc_windows1257 -> "WINDOWS-1257"
- | `Enc_windows1258 -> "WINDOWS-1258"
- | `Enc_cp437 -> "CP437"
- | `Enc_cp737 -> "CP737"
- | `Enc_cp775 -> "CP775"
- | `Enc_cp850 -> "CP850"
- | `Enc_cp852 -> "CP852"
- | `Enc_cp855 -> "CP855"
- | `Enc_cp856 -> "CP856"
- | `Enc_cp857 -> "CP857"
- | `Enc_cp860 -> "CP860"
- | `Enc_cp861 -> "CP861"
- | `Enc_cp862 -> "CP862"
- | `Enc_cp863 -> "CP863"
- | `Enc_cp864 -> "CP864"
- | `Enc_cp865 -> "CP865"
- | `Enc_cp866 -> "CP866"
- | `Enc_cp869 -> "CP869"
- | `Enc_cp874 -> "CP874"
- | `Enc_cp1006 -> "CP1006"
- | `Enc_cp037 -> "CP037"
- | `Enc_cp424 -> "CP424"
- | `Enc_cp500 -> "CP500"
- | `Enc_cp875 -> "CP875"
- | `Enc_cp1026 -> "CP1026"
- | `Enc_adobe_standard_encoding -> "ADOBE-STANDARD-ENCODING"
- | `Enc_adobe_symbol_encoding -> "ADOBE-SYMBOL-ENCODING"
- | `Enc_adobe_zapf_dingbats_encoding -> "ADOBE-ZAPF-DINGBATS-ENCODING"
- | `Enc_macroman -> "MACINTOSH"
-;;
-
-
-let read_iso88591 write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in < l_in then begin
- let p = Char.code s_in.[p_in + k_in] in
- let n = write p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_iso88591
- else
- scan (k_in + 1) (k_out + n) (c_out + 1)
- end
- else
- k_in, k_out, `Enc_iso88591
- in
- scan 0 0 0
-;;
-
-
-let read_usascii write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in < l_in then begin
- let p = Char.code s_in.[p_in + k_in] in
- if p >= 0x80 then raise Malformed_code;
- let n = write p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_usascii
- else
- scan (k_in + 1) (k_out + n) (c_out + 1)
- end
- else
- k_in, k_out, `Enc_usascii
- in
- scan 0 0 0
-;;
-
-
-let read_8bit m_to_unicode enc write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in < l_in then begin
- let p_local = Char.code s_in.[p_in + k_in] in
- let p_uni = Array.unsafe_get m_to_unicode p_local in
- if p_uni < 0 then raise Malformed_code;
- let n = write p_uni k_out c_out in
- if n < 0 then
- k_in, k_out, enc
- else
- scan (k_in + 1) (k_out + n) (c_out + 1)
- end
- else
- k_in, k_out, enc
- in
- scan 0 0 0
-;;
-
-
-let read_utf8 is_java write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in < l_in then begin
- let n_out, n_in =
- match s_in.[p_in + k_in] with
- '\000' ->
- if is_java then raise Malformed_code;
- write 0 k_out c_out, 1
- | ('\001'..'\127' as c) ->
- write (Char.code c) k_out c_out, 1
- | ('\128'..'\223' as c) ->
- if k_in + 1 >= l_in then
- -1, 0
- else begin
- let n1 = Char.code c in
- let n2 = Char.code (s_in.[p_in + k_in + 1]) in
- if is_java && (n1 = 0x80 && n2 = 0xc0) then
- write 0 k_out c_out, 2
- else begin
- if n2 < 128 or n2 > 191 then raise Malformed_code;
- let p = ((n1 land 0b11111) lsl 6) lor (n2 land 0b111111) in
- if p < 128 then raise Malformed_code;
- write p k_out c_out, 2
- end
- end
- | ('\224'..'\239' as c) ->
- if k_in + 2 >= l_in then
- -1, 0
- else begin
- let n1 = Char.code c in
- let n2 = Char.code (s_in.[p_in + k_in + 1]) in
- let n3 = Char.code (s_in.[p_in + k_in + 2]) in
- if n2 < 128 or n2 > 191 then raise Malformed_code;
- if n3 < 128 or n3 > 191 then raise Malformed_code;
- let p =
- ((n1 land 0b1111) lsl 12) lor
- ((n2 land 0b111111) lsl 6) lor
- (n3 land 0b111111)
- in
- if p < 0x800 then raise Malformed_code;
- if (p >= 0xd800 && p < 0xe000) then
- (* Surrogate pairs are not supported in UTF-8 *)
- raise Malformed_code;
- if (p >= 0xfffe && p <= 0xffff) then
- raise Malformed_code;
- write p k_out c_out, 3
- end
- | ('\240'..'\247' as c) ->
- if k_in + 3 >= l_in then
- -1, 0
- else begin
- let n1 = Char.code c in
- let n2 = Char.code (s_in.[p_in + k_in + 1]) in
- let n3 = Char.code (s_in.[p_in + k_in + 2]) in
- let n4 = Char.code (s_in.[p_in + k_in + 3]) in
- if n2 < 128 or n2 > 191 then raise Malformed_code;
- if n3 < 128 or n3 > 191 then raise Malformed_code;
- if n4 < 128 or n4 > 191 then raise Malformed_code;
- let p = ((n1 land 0b111) lsl 18) lor
- ((n2 land 0b111111) lsl 12) lor
- ((n3 land 0b111111) lsl 6) lor
- (n4 land 0b111111)
- in
- if p < 0x10000 then raise Malformed_code;
- if p >= 0x110000 then
- (* These code points are not supported. *)
- raise Malformed_code;
- write p k_out c_out, 4
- end
- | _ ->
- (* Outside the valid range of XML characters *)
- raise Malformed_code;
- in
- (* n_out: number of written bytes; -1 means out buf is full
- * n_in: number of read bytes; 0 means end of in buf reached
- * n_in = 0 implies n_out = -1
- *)
- if n_out < 0 then
- k_in, k_out, `Enc_utf8
- else
- scan (k_in + n_in) (k_out + n_out) (c_out + 1)
- end
- else
- k_in, k_out, `Enc_utf8
- in
- scan 0 0 0
-;;
-
-
-let surrogate_offset = 0x10000 - (0xD800 lsl 10) - 0xDC00;;
-
-let read_utf16_le k_in_0 write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in + 1 < l_in then begin
- let p = (Char.code s_in.[p_in + k_in]) lor ((Char.code s_in.[p_in + k_in + 1]) lsl 8) in
-
- if p >= 0xd800 & p < 0xe000 then begin
- (* This is a surrogate pair. *)
- if k_in + 3 < l_in then begin
- if p <= 0xdbff then begin
- let q = (Char.code s_in.[p_in + k_in + 2 ]) lor
- ((Char.code s_in.[p_in + k_in + 3]) lsl 8) in
- if q < 0xdc00 or q > 0xdfff then raise Malformed_code;
- let eff_p = (p lsl 10) + q + surrogate_offset in
- let n = write eff_p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_utf16_le
- else
- scan (k_in + 4) (k_out + n) (c_out + 1)
- end
- else
- (* Malformed pair: *)
- raise Malformed_code;
- end
- else
- (* Incomplete pair: *)
- k_in, k_out, `Enc_utf16_le
- end
-
- else
- if p = 0xfffe then
- (* Big endian byte order mark: It is illegal here *)
- raise Malformed_code
- else begin
- (* A regular code point *)
- let n = write p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_utf16_le
- else
- scan (k_in + 2) (k_out + n) (c_out + 1)
- end
- end
- else
- (* Incomplete character: *)
- k_in, k_out, `Enc_utf16_le
- in
- scan k_in_0 0 0
-;;
-
-
-let read_utf16_be k_in_0 write s_in p_in l_in =
- let rec scan k_in k_out c_out =
- if k_in + 1 < l_in then begin
- let p = (Char.code s_in.[p_in + k_in + 1]) lor ((Char.code s_in.[p_in + k_in]) lsl 8) in
-
- if p >= 0xd800 & p < 0xe000 then begin
- (* This is a surrogate pair. *)
- if k_in + 3 < l_in then begin
- if p <= 0xdbff then begin
- let q = (Char.code s_in.[p_in + k_in + 3 ]) lor
- ((Char.code s_in.[p_in + k_in + 2]) lsl 8) in
- if q < 0xdc00 or q > 0xdfff then raise Malformed_code;
- let eff_p = (p lsl 10) + q + surrogate_offset in
- let n = write eff_p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_utf16_be
- else
- scan (k_in + 4) (k_out + n) (c_out + 1)
- end
- else
- (* Malformed pair: *)
- raise Malformed_code;
- end
- else
- (* Incomplete pair: *)
- k_in, k_out, `Enc_utf16_be
- end
-
- else
- if p = 0xfffe then
- (* Little endian byte order mark: It is illegal here *)
- raise Malformed_code
- else begin
- (* A regular code point *)
- let n = write p k_out c_out in
- if n < 0 then
- k_in, k_out, `Enc_utf16_be
- else
- scan (k_in + 2) (k_out + n) (c_out + 1)
- end
-
- end
- else
- (* Incomplete character: *)
- k_in, k_out, `Enc_utf16_be
- in
- scan k_in_0 0 0
-;;
-
-
-let read_utf16 write s_in p_in l_in =
- (* Expect a BOM at the beginning of the text *)
- if l_in >= 2 then begin
- let c0 = s_in.[p_in + 0] in
- let c1 = s_in.[p_in + 1] in
- if c0 = '\254' & c1 = '\255' then begin
- (* 0xfeff as big endian *)
- read_utf16_be 2 write s_in p_in l_in
- end
- else
- if c0 = '\255' & c1 = '\254' then begin
- (* 0xfeff as little endian *)
- read_utf16_le 2 write s_in p_in l_in
- end
- else
- (* byte order mark missing *)
- raise Malformed_code
- end
- else
- 0, 0, `Enc_utf16
-;;
-
-
-let write_iso88591 s_out p_out l_out max_chars w p k_out c_out =
- if k_out < l_out && c_out < max_chars then begin
- if p > 255 then begin
- let subst = w p in
- let l_subst = String.length subst in
- if k_out + l_subst <= l_out then begin
- (* Enough space to store 'subst': *)
- String.blit subst 0 s_out (k_out+p_out) l_subst;
- l_subst
- end
- else
- (* Not enough space: Stop this round of recoding *)
- -1
- end
- else begin
- s_out.[p_out + k_out] <- Char.chr p;
- 1
- end
- end
- else
- -1 (* End-of-buffer indicator *)
-;;
-
-
-let write_usascii s_out p_out l_out max_chars w p k_out c_out =
- if k_out < l_out && c_out < max_chars then begin
- if p > 127 then begin
- let subst = w p in
- let l_subst = String.length subst in
- if k_out + l_subst <= l_out then begin
- (* Enough space to store 'subst': *)
- String.blit subst 0 s_out (k_out+p_out) l_subst;
- l_subst
- end
- else
- (* Not enough space: Stop this round of recoding *)
- -1
- end
- else begin
- s_out.[p_out + k_out] <- Char.chr p;
- 1
- end
- end
- else
- -1 (* End-of-buffer indicator *)
-;;
-
-
-let write_8bit from_unicode s_out p_out l_out max_chars w p k_out c_out =
- if k_out < l_out && c_out < max_chars then begin
- let p' =
- match Array.unsafe_get from_unicode (p land 255) with
- Netmappings.U_nil -> -1
- | Netmappings.U_single (p0,q0) ->
- if p0 = p then q0 else -1
- | Netmappings.U_list l ->
- (try List.assoc p l with Not_found -> -1)
- in
- if p' < 0 then begin
- let subst = w p in
- let l_subst = String.length subst in
- if k_out + l_subst <= l_out then begin
- (* Enough space to store 'subst': *)
- String.blit subst 0 s_out (k_out+p_out) l_subst;
- l_subst
- end
- else
- (* Not enough space: Stop this round of recoding *)
- -1
- end
- else begin
- s_out.[p_out + k_out] <- Char.chr p';
- 1
- end
- end
- else
- -1 (* End-of-buffer indicator *)
-;;
-
-
-let write_utf8 is_java s_out p_out l_out max_chars w p k_out c_out =
- if p <= 127 && (not is_java || p <> 0) then begin
- if k_out < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out] <- Char.chr p;
- 1
- end
- else -1
- end
- else if p <= 0x7ff then begin
- if k_out + 1 < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out] <- Char.chr (0xc0 lor (p lsr 6));
- s_out.[p_out + k_out + 1] <- Char.chr (0x80 lor (p land 0x3f));
- 2
- end
- else -1
- end
- else if p <= 0xffff then begin
- (* Refuse writing surrogate pairs, and fffe, ffff *)
- if (p >= 0xd800 & p < 0xe000) or (p >= 0xfffe) then
- failwith "Netconversion.write_utf8";
- if k_out + 2 < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out] <- Char.chr (0xe0 lor (p lsr 12));
- s_out.[p_out + k_out + 1] <- Char.chr (0x80 lor ((p lsr 6) land 0x3f));
- s_out.[p_out + k_out + 2] <- Char.chr (0x80 lor (p land 0x3f));
- 3
- end
- else -1
- end
- else if p <= 0x10ffff then begin
- if k_out + 3 < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out] <- Char.chr (0xf0 lor (p lsr 18));
- s_out.[p_out + k_out + 1] <- Char.chr (0x80 lor ((p lsr 12) land 0x3f));
- s_out.[p_out + k_out + 2] <- Char.chr (0x80 lor ((p lsr 6) land 0x3f));
- s_out.[p_out + k_out + 3] <- Char.chr (0x80 lor (p land 0x3f));
- 4
- end
- else -1
- end
- else
- (* Higher code points are not possible in XML: *)
- failwith "Netconversion.write_utf8"
-;;
-
-
-let write_utf16_le s_out p_out l_out max_chars w p k_out c_out =
- if p >= 0xfffe then begin
- if p <= 0xffff or p > 0x10ffff then failwith "Netconversion.write_utf16_le";
- (* Must be written as surrogate pair *)
- if k_out + 3 < l_out && c_out < max_chars then begin
- let high = (p lsr 10) + 0xd800 in
- let low = (p land 0x3ff) + 0xdc00 in
- s_out.[p_out + k_out ] <- Char.chr (high land 0xff);
- s_out.[p_out + k_out + 1] <- Char.chr (high lsr 8);
- s_out.[p_out + k_out + 2] <- Char.chr (low land 0xff);
- s_out.[p_out + k_out + 3] <- Char.chr (low lsr 8);
- 4
- end
- else -1
- end
- else begin
- if k_out + 1 < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out ] <- Char.chr (p land 0xff);
- s_out.[p_out + k_out + 1] <- Char.chr (p lsr 8);
- 2
- end
- else
- -1
- end
-;;
-
-
-let write_utf16_be s_out p_out l_out max_chars w p k_out c_out =
- if p >= 0xfffe then begin
- if p <= 0xffff or p > 0x10ffff then failwith "Netconversion.write_utf16_be";
- (* Must be written as surrogate pair *)
- if k_out + 3 < l_out && c_out < max_chars then begin
- let high = (p lsr 10) + 0xd800 in
- let low = (p land 0x3ff) + 0xdc00 in
- s_out.[p_out + k_out + 1] <- Char.chr (high land 0xff);
- s_out.[p_out + k_out ] <- Char.chr (high lsr 8);
- s_out.[p_out + k_out + 3] <- Char.chr (low land 0xff);
- s_out.[p_out + k_out + 2] <- Char.chr (low lsr 8);
- 4
- end
- else -1
- end
- else begin
- if k_out + 1 < l_out && c_out < max_chars then begin
- s_out.[p_out + k_out + 1] <- Char.chr (p land 0xff);
- s_out.[p_out + k_out ] <- Char.chr (p lsr 8);
- 2
- end
- else
- -1
- end
-;;
-
-
-let recode ~in_enc
- ~in_buf
- ~in_pos
- ~in_len
- ~out_enc
- ~out_buf
- ~out_pos
- ~out_len
- ~max_chars
- ~subst =
- if (in_pos < 0 || in_len < 0 || in_pos + in_len > String.length in_buf ||
- out_pos < 0 || out_len < 0 || out_pos + out_len > String.length out_buf)
- then
- invalid_arg "Netconversion.recode";
-
- let reader =
- match in_enc with
- `Enc_iso88591 -> read_iso88591
- | `Enc_usascii -> read_usascii
- | `Enc_utf8 -> read_utf8 false
- | `Enc_java -> read_utf8 true
- | `Enc_utf16 -> read_utf16
- | `Enc_utf16_le -> read_utf16_le 0
- | `Enc_utf16_be -> read_utf16_be 0
- | _ ->
- (try
- let to_unicode' = Hashtbl.find Netmappings.to_unicode in_enc in
- let to_unicode =
- Netmappings.lock();
- Lazy.force to_unicode' in
- Netmappings.unlock();
- read_8bit to_unicode in_enc
- with
- Not_found ->
- failwith("Support for the encoding `" ^
- string_of_encoding in_enc ^
- "' has not been compiled into Netstring")
- )
- in
- let writer =
- match out_enc with
- `Enc_iso88591 -> write_iso88591 out_buf out_pos out_len max_chars subst
- | `Enc_usascii -> write_usascii out_buf out_pos out_len max_chars subst
- | `Enc_utf8 -> write_utf8 false
- out_buf out_pos out_len max_chars subst
- | `Enc_java -> write_utf8 true out_buf out_pos out_len max_chars subst
- | `Enc_utf16 -> failwith "Netconversion.recode"
- | `Enc_utf16_le -> write_utf16_le out_buf out_pos out_len max_chars subst
- | `Enc_utf16_be -> write_utf16_be out_buf out_pos out_len max_chars subst
- | _ ->
- (try
- let from_unicode' = Hashtbl.find Netmappings.from_unicode out_enc
- in
- let from_unicode =
- Netmappings.lock();
- Lazy.force from_unicode' in
- Netmappings.unlock();
- write_8bit from_unicode out_buf out_pos out_len max_chars subst
- with
- Not_found ->
- failwith("Support for the encoding `" ^
- string_of_encoding out_enc ^
- "' has not been compiled into Netstring")
- )
- in
- reader writer in_buf in_pos in_len
-;;
-
-
-let makechar enc p =
- match enc with
- `Enc_iso88591 ->
- if p > 255 then raise Not_found;
- String.make 1 (Char.chr p)
- | `Enc_usascii ->
- if p > 127 then raise Not_found;
- String.make 1 (Char.chr p)
- | `Enc_utf8 ->
- let s = String.create 4 in
- let n = write_utf8 false s 0 4 1 (fun _ -> raise Not_found) p 0 0 in
- String.sub s 0 n
- | `Enc_java ->
- let s = String.create 4 in
- let n = write_utf8 true s 0 4 1 (fun _ -> raise Not_found) p 0 0 in
- String.sub s 0 n
- | `Enc_utf16_le ->
- let s = String.create 4 in
- let n = write_utf16_le s 0 4 1 (fun _ -> raise Not_found) p 0 0 in
- String.sub s 0 n
- | `Enc_utf16_be ->
- let s = String.create 4 in
- let n = write_utf16_be s 0 4 1 (fun _ -> raise Not_found) p 0 0 in
- String.sub s 0 n
- | `Enc_utf16 ->
- failwith "Netconversion.makechar"
- | _ ->
- let s = String.create 1 in
- let from_unicode' =
- try
- Hashtbl.find Netmappings.from_unicode enc
- with
- Not_found ->
- failwith("Support for the encoding `" ^
- string_of_encoding enc ^
- "' has not been compiled into Netstring")
- in
- let from_unicode =
- Netmappings.lock();
- Lazy.force from_unicode' in
- Netmappings.unlock();
- let n =
- write_8bit from_unicode s 0 1 1 (fun _ -> raise Not_found) p 0 0 in
- s
-;;
-
-
-let recode_string ~in_enc ~out_enc ?(subst = (fun _ -> raise Not_found)) s =
-
- let length = String.length s in
- let size = 1024 in
- let out_buf = String.create size in
-
- let rec recode_loop k s_done in_enc =
- (* 'k' bytes of 's' have already been processed, and the result is in
- * 's_done'.
- *)
- (* Recode to 'out_buf': *)
- let in_len = length - k in
- let in_done, out_done, in_enc' =
- recode ~in_enc:in_enc ~in_buf:s ~in_pos:k ~in_len:in_len
- ~out_enc:out_enc ~out_buf:out_buf ~out_pos:0 ~out_len:size
- ~max_chars:size ~subst:subst in
- (* Collect the results: *)
- let k' = k + in_done in
- let s_done' = String.sub out_buf 0 out_done :: s_done in
- (* Still something to do? *)
- if k' < length then
- recode_loop k' s_done' in_enc'
- else
- (* No: Concatenate s_done' to get the final result. *)
- String.concat "" (List.rev s_done')
- in
-
- recode_loop 0 [] in_enc
-;;
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:28 lpadovan
- * Initial revision
- *
- * Revision 1.2 2000/08/29 00:46:41 gerd
- * New type for the Unicode to 8 bit translation table.
- * The Netmappings tables are now Lazy.t.
- *
- * Revision 1.1 2000/08/13 00:02:57 gerd
- * Initial revision.
- *
- *
- * ======================================================================
- * OLD LOGS FROM THE PXP PACKAGE (FILE NAME pxp_encoding.ml):
- *
- * Revision 1.5 2000/07/27 00:41:14 gerd
- * new 8 bit codes
- *
- * Revision 1.4 2000/07/04 22:11:41 gerd
- * Implemented the enhancements and extensions of
- * rev. 1.4 of pxp_encoding.mli.
- *
- * Revision 1.3 2000/05/29 23:48:38 gerd
- * Changed module names:
- * Markup_aux into Pxp_aux
- * Markup_codewriter into Pxp_codewriter
- * Markup_document into Pxp_document
- * Markup_dtd into Pxp_dtd
- * Markup_entity into Pxp_entity
- * Markup_lexer_types into Pxp_lexer_types
- * Markup_reader into Pxp_reader
- * Markup_types into Pxp_types
- * Markup_yacc into Pxp_yacc
- * See directory "compatibility" for (almost) compatible wrappers emulating
- * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
- *
- * Revision 1.2 2000/05/29 21:14:57 gerd
- * Changed the type 'encoding' into a polymorphic variant.
- *
- * Revision 1.1 2000/05/20 20:30:50 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff