print_xml.ml 1.59 KB
Newer Older
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
(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
open Value

let exn_print_xml = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
				 string "print_xml"))


let to_enc = `Enc_iso88591

let string_of_xml v= 
  let buffer = Buffer.create 127 in

  let wms = 
    write_markup_string
      ~from_enc:`Enc_iso88591 
      ~to_enc
      (`Out_buffer buffer)

  and wds =
    write_data_string
      ~from_enc:`Enc_iso88591 
      ~to_enc
      (`Out_buffer buffer)
  in
  let comment s = wms ("<!--" ^ s ^ "-->")
  and write_att (n,v) = wms (" " ^ n ^ "=\""); wds v; wms "\"" in
  let element_start name attrs = 
    wms ("<" ^ name); List.iter write_att attrs; wms "\n>"
  and element_end name = wms ("</" ^ name ^ "\n>")
  and document_start () = 
    wms ("<?xml version='1.0' encoding='" ^
	 Netconversion.string_of_encoding to_enc ^
	 "'?>\n")
  and text s = wds s in

  let rec print_elt = function
    | Pair (Atom tag, Pair (Record attrs, content)) ->
	let tag = Types.atom_name tag in
	element_start tag
	  (List.map (fun (n,v) -> 
		       if not (is_str v) then raise exn_print_xml;
		       (Types.label_name n,get_string v)) attrs);
	print_content content;
	element_end tag
    | Char x ->
 	wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
   | _ -> raise exn_print_xml
  and print_content = function
    | String (i,j,s,q) ->
	wds (String.sub s i (j - i));
	print_content q
    | Pair (elt, q) ->
	print_elt elt;
	print_content q
    | Atom a when a = Sequence.nil_atom -> true
    | _ -> raise exn_print_xml
  in
  document_start ();
  print_elt v;
  Buffer.contents buffer