(* $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.
 *
 * 
 *)