print_xml.ml 5.8 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
(* Print XML documents *)

(* The write_*_function are inspired from Pxp_aux.ml *)

open Netconversion

let write_markup_string ~to_enc buf s =
  let s' = if to_enc = `Enc_utf8 then s
  else convert
    ~in_enc:`Enc_utf8
    ~out_enc:to_enc
    ~subst:(fun n -> 
	      failwith ("Cannot represent code point " ^ string_of_int n))
    s
  in
  Buffer.add_string buf s'

let write_data_string ~to_enc buf s =
  let write_part i len =
    if (len > 0) then
      if to_enc = `Enc_utf8 
      then Buffer.add_substring buf s i len
      else
	let s' = 
	  convert
            ~in_enc:`Enc_utf8
            ~out_enc:to_enc
            ~subst:(fun n -> "&#" ^ string_of_int n ^ ";")
	    ~range_pos:i ~range_len:len s
	in
	Buffer.add_string buf s'
  in
  let i = ref 0 in
  for k = 0 to String.length s - 1 do
    match s.[k] with
      | ('&' | '<' | '>' | '"' | '%') as c ->
          write_part !i (k - !i);
          begin match c with
              '&' -> Buffer.add_string buf "&amp;"
            | '<' -> Buffer.add_string buf "&lt;"
            | '>' -> Buffer.add_string buf "&gt;"
            | '"' -> Buffer.add_string buf "&quot;"
            | '%' -> Buffer.add_string buf "&#37;"  (* reserved in DTDs *)
            | _   -> assert false
          end;
          i := k+1
      | _ -> ()
  done;
  write_part !i (String.length s - !i)


(*************)

54
55

open Value
56
open Ident
57
module U = Encodings.Utf8
58

59
let exn_print_xml = CDuceExn (Pair (
60
				Atom (Atoms.V.mk_ascii "Invalid_argument"),
61
				string_latin1 "print_xml"))
62

63
64
65
66
67
68
let blank = U.mk " "
let true_literal = U.mk "true"
let false_literal = U.mk "false"

  (* @raise exn_print_xml in case of failure. Rationale: schema printing is
   * the last attempt to print a value, others have already failed *)
69
70
71
let rec schema_value ?(recurs=true) ~wds v = match v with
  | Abstract ("float",f) ->
      wds (U.mk (string_of_float (Obj.magic f : float)))
72
73
74
  | Record _ as v ->
      (try
        wds (Schema_builtin.string_of_time_type (Value.get_fields v))
75
      with Schema_builtin.Error _ -> raise exn_print_xml)
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
  | Integer i -> wds (U.mk (Intervals.V.to_string i))
  | v when Value.equal v Value.vtrue -> wds true_literal
  | v when Value.equal v Value.vfalse -> wds false_literal
  | Pair _ as v when recurs -> schema_values ~wds v
  | String_utf8 _ as v -> wds (fst (get_string_utf8 v))
  | _ -> raise exn_print_xml

and schema_values ~wds v =
  match v with
  | Pair (hd, Atom a) when a = Sequence.nil_atom ->
      schema_value ~recurs:false ~wds hd
  | Pair (hd, tl) ->
      schema_value ~recurs:false ~wds hd;
      wds blank;
      schema_values ~wds tl
  | _ -> raise exn_print_xml

93
let string_of_xml ~utf8 ns_table v = 
94
  let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
95
96

  let buffer = Buffer.create 127 in
97
  let printer = Ns.Printer.printer ns_table in
98

99
100
  let wms = write_markup_string ~to_enc buffer
  and wds s = write_data_string ~to_enc buffer (U.get_str s)
101
  in
102
103
104
105
106
107
108
109
110
  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
111

112
113
114
115
116
117
118
119
120
121
122
123
  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) ^ ">")
124
  and document_start () = 
125
(*    wms ("<?xml version='1.0' encoding='" ^
126
	 Netconversion.string_of_encoding to_enc ^
127
	 "'?>\n") *)
128
    ()
129
  in
130

131
  let rec register_elt = function
132
133
    | Xml (Atom tag, Record attrs, content) 
    | XmlNs (Atom tag, Record attrs, content, _) ->
134
135
136
	Imap.iter
	  (fun n _ -> Ns.Printer.register_attr printer (LabelPool.value n))
	  attrs;
137
	Ns.Printer.register_tag printer (Atoms.V.value tag);
138
139
140
141
142
143
	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
144
    | Concat (x,y) -> register_content x; register_content y
145
146
147
148
149
    | _ -> () 
  in
  register_elt v;

  let rec print_elt xmlns = function
150
151
    | Xml (Atom tag, Record attrs, content)
    | XmlNs (Atom tag, Record attrs, content, _) ->
152
	let tag = Atoms.V.value tag in
153
	let attrs = Imap.map_elements
154
		      (fun n v -> 
155
156
157
158
159
160
161
162
163
164
165
166
                         if is_str v then begin
                           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
                         end else begin
                           let buf = Buffer.create 20 in
                           let wds s = Buffer.add_string buf (U.get_str s) in
                           schema_value ~wds v;
                           (LabelPool.value n, U.mk (Buffer.contents buf))
                         end
167
		      ) attrs in
168
	(match content with
169
	  | Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
170
	  | _ ->
171
	      element_start tag xmlns attrs;
172
173
	      print_content content;
	      element_end tag)
174
    | _ -> raise exn_print_xml
175
176
177
178
  and print_content v =
    let (s,q) = get_string_utf8 v in
    wds s;
    match q with
179
      | Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
180
      | Atom a when a = Sequence.nil_atom -> ()
181
      | v -> schema_value ~wds v
182
183
  in
  document_start ();
184
  print_elt (Ns.Printer.prefixes printer) v;
185
  Buffer.contents buffer
186

187
let print_xml ~utf8 ns_table s =
188
189
  let s = string_of_xml ~utf8 ns_table s in
  if utf8 then string_utf8 (U.mk s) else string_latin1 s
190