print_xml.ml 3.06 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
module U = Encodings.Utf8
8

9
let exn_print_xml = CDuceExn (Pair (
10
				Atom (Atoms.V.mk_ascii "Invalid_argument"),
11
				string_latin1 "print_xml"))
12

13
let string_of_xml ~utf8 ns_table v = 
14
  let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
15 16

  let buffer = Buffer.create 127 in
17
  let printer = Ns.Printer.printer ns_table in
18 19 20

  let wms = 
    write_markup_string
21
      ~from_enc:`Enc_utf8 
22 23 24
      ~to_enc
      (`Out_buffer buffer)

25
  and wds s =
26
    write_data_string
27
      ~from_enc:`Enc_utf8
28 29
      ~to_enc
      (`Out_buffer buffer)
30
      (U.get_str s)
31
  in
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
  let write_att (n,v) =
    wms (" " ^ (Ns.Printer.attr printer n) ^ "=\""); wds v; wms "\"" in
  let write_xmlns (pr,ns) =
    let pr = U.get_str pr in
    if pr = "" then wms " xmlns"
    else (wms " xmlns:"; wms pr);
    wms "=\"";
    wds (Ns.value ns);
    wms "\"" in
  let element_start n xmlns attrs = 
    wms ("<" ^ (Ns.Printer.tag printer n)); 
    List.iter write_xmlns xmlns;
    List.iter write_att attrs; 
    wms ">"
  and empty_element n xmlns attrs = 
    wms ("<" ^ (Ns.Printer.tag printer n)); 
    List.iter write_xmlns xmlns;
    List.iter write_att attrs; 
    wms "/>"
  and element_end n = 
    wms ("</" ^ (Ns.Printer.attr printer n) ^ ">")
53
  and document_start () = 
54
(*    wms ("<?xml version='1.0' encoding='" ^
55
	 Netconversion.string_of_encoding to_enc ^
56
	 "'?>\n") *)
57
    ()
58
  in
59

60 61 62 63 64
  let rec register_elt = function
    | Xml (Atom tag, Record attrs, content) ->
	List.iter
	  (fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
	  (LabelMap.get attrs);
65
	Ns.Printer.register_tag printer (Atoms.V.value tag);
66 67 68 69 70 71 72 73 74 75 76
	register_content content
    | _ -> ()
  and register_content = function
    | String_utf8 (_,_,_,q)
    | String_latin1 (_,_,_,q) -> register_content q
    | Pair (x, q) -> register_elt x; register_content q
    | _ -> () 
  in
  register_elt v;

  let rec print_elt xmlns = function
77
    | Xml (Atom tag, Record attrs, content) ->
78
	let tag = Atoms.V.value tag in
79 80 81
	let attrs = LabelMap.mapi_to_list 
		      (fun n v -> 
			 if not (is_str v) then raise exn_print_xml;
82 83
			 let (s,q) = get_string_utf8 v in
			 match q with
84 85
			   | Atom a when a = Sequence.nil_atom -> 
			       (LabelPool.value n), s
86 87
			   | _ -> raise exn_print_xml
		      ) attrs in
88
	(match content with
89
	  | Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
90
	  | _ ->
91
	      element_start tag xmlns attrs;
92 93
	      print_content content;
	      element_end tag)
94
    | _ -> raise exn_print_xml
95 96 97 98
  and print_content v =
    let (s,q) = get_string_utf8 v in
    wds s;
    match q with
99
      | Pair (x, q) -> print_elt [] x; print_content q
100 101
      | Atom a when a = Sequence.nil_atom -> ()
      | _ -> raise exn_print_xml
102 103
  in
  document_start ();
104
  print_elt (Ns.Printer.prefixes printer) v;
105
  Buffer.contents buffer
106

107
let print_xml ~utf8 ns_table s =
108
  try   
109
    let s = string_of_xml ~utf8 ns_table s in
110 111 112 113 114
    if utf8 then string_utf8 (U.mk s) else string_latin1 s
  with exn ->
    raise
      (Location.Generic (Pxp_types.string_of_exn exn))