print_xml.ml 2.14 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.mk_ascii "Invalid_argument"),
11
				string_latin1 "print_xml"))
12

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

  let buffer = Buffer.create 127 in

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

24
  and wds s =
25
    write_data_string
26
      ~from_enc:`Enc_utf8
27
28
      ~to_enc
      (`Out_buffer buffer)
29
      (U.get_str s)
30
  in
31
  let write_att (n,v) = wms (" " ^ (U.get_str n) ^ "=\""); wds v; wms "\"" in
32
  let element_start name attrs = 
33
    wms ("<" ^ (U.get_str name)); List.iter write_att attrs; wms ">"
34
  and empty_element name attrs = 
35
36
    wms ("<" ^ (U.get_str name)); List.iter write_att attrs; wms "/>"
  and element_end name = wms ("</" ^ (U.get_str name) ^ ">")
37
  and document_start () = 
38
(*    wms ("<?xml version='1.0' encoding='" ^
39
	 Netconversion.string_of_encoding to_enc ^
40
41
	 "'?>\n") *)
      ()
42
  in
43
44

  let rec print_elt = function
45
    | Xml (Atom tag, Pair (Record attrs, content)) ->
46
	let tag = Atoms.value tag in
47
48
49
	let attrs = LabelMap.mapi_to_list 
		      (fun n v -> 
			 if not (is_str v) then raise exn_print_xml;
50
51
52
53
54
			 let (s,q) = get_string_utf8 v in
			 match q with
			   | Atom a when a = Sequence.nil_atom -> LabelPool.value n, s
			   | _ -> raise exn_print_xml
		      ) attrs in
55
56
57
58
59
60
	(match content with
	  | Atom a when a = Sequence.nil_atom -> empty_element tag attrs
	  | _ ->
	      element_start tag attrs;
	      print_content content;
	      element_end tag)
61
    | _ -> raise exn_print_xml
62
63
64
65
66
67
68
  and print_content v =
    let (s,q) = get_string_utf8 v in
    wds s;
    match q with
      | Pair (x, q) -> print_elt x; print_content q
      | Atom a when a = Sequence.nil_atom -> ()
      | _ -> raise exn_print_xml
69
70
71
72
  in
  document_start ();
  print_elt v;
  Buffer.contents buffer
73
74
75
76
77
78
79
80
81

let print_xml ~utf8 s =
  try   
    let s = string_of_xml ~utf8 s in
    if utf8 then string_utf8 (U.mk s) else string_latin1 s
  with exn ->
    raise
      (Location.Generic (Pxp_types.string_of_exn exn))