print_xml.ml 1.96 KB
Newer Older
1 2 3 4 5
(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
open Value
6
open Ident
7

8
let exn_print_xml = CDuceExn (Pair (
9
				Atom (Atoms.mk "Invalid_argument"),
10
				string_latin1 "print_xml"))
11 12 13 14 15 16 17 18 19 20 21 22

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)

23
  and wds ?(from_enc=`Enc_iso88591) =
24
    write_data_string
25
      ~from_enc
26 27 28 29 30 31
      ~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 = 
32
    wms ("<" ^ name); List.iter write_att attrs; wms ">"
33 34
  and empty_element name attrs = 
    wms ("<" ^ name); List.iter write_att attrs; wms "/>"
35
  and element_end name = wms ("</" ^ name ^ ">")
36
  and document_start () = 
37
(*    wms ("<?xml version='1.0' encoding='" ^
38
	 Netconversion.string_of_encoding to_enc ^
39 40
	 "'?>\n") *)
      ()
41 42 43
  and text s = wds s in

  let rec print_elt = function
44
    | Xml (Atom tag, Pair (Record attrs, content)) ->
45
	let tag = Atoms.value tag in
46 47 48
	let attrs = LabelMap.mapi_to_list 
		      (fun n v -> 
			 if not (is_str v) then raise exn_print_xml;
49
			 (LabelPool.value n,get_string_latin1 v)) attrs in
50 51 52 53 54 55
	(match content with
	  | Atom a when a = Sequence.nil_atom -> empty_element tag attrs
	  | _ ->
	      element_start tag attrs;
	      print_content content;
	      element_end tag)
56
    | Char x ->
57
 	wds (String.make 1 (Chars.to_char x)); (* TODO: opt *)
58 59
   | _ -> raise exn_print_xml
  and print_content = function
60
    | String_latin1 (i,j,s,q) ->
61 62
	wds (String.sub s i (j - i));
	print_content q
63 64 65
    | String_utf8 (i,j,s,q) ->
	wds ~from_enc:`Enc_utf8 (Encodings.Utf8.get_substr s i j);
	print_content q
66 67 68 69 70 71 72 73 74
    | 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