viewcvs.cgi/runtime/print_xml.ml

(* 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)


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


open Value
open Ident
module U = Encodings.Utf8

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

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 *)
let rec schema_value ?(recurs=true) ~wds v = match v with
  | Abstract ("float",f) ->
      wds (U.mk (string_of_float (Obj.magic f : float)))
  | Record _ as v ->
      (try
        wds (Schema_builtin.string_of_time_type (Value.get_fields v))
      with Schema_builtin.Error _ -> raise exn_print_xml)
  | 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

let string_of_xml ~utf8 ns_table v = 
  let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in

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

  let wms = write_markup_string ~to_enc buffer
  and wds s = write_data_string ~to_enc buffer (U.get_str s)
  in
  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) ^ ">")
  and document_start () = 
(*    wms ("<?xml version='1.0' encoding='" ^
         Netconversion.string_of_encoding to_enc ^
         "'?>\n") *)
    ()
  in

  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);
        Ns.Printer.register_tag printer (Atoms.V.value tag);
        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
    | Concat (x,y) -> register_content x; register_content y
    | _ -> () 
  in
  register_elt v;

  let rec print_elt xmlns = function
    | Xml (Atom tag, Record attrs, content) ->
        let tag = Atoms.V.value tag in
        let attrs = LabelMap.mapi_to_list 
                      (fun n v -> 
                         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
                      ) attrs in
        (match content with
          | Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
          | _ ->
              element_start tag xmlns attrs;
              print_content content;
              element_end tag)
    | _ -> raise exn_print_xml
  and print_content v =
    let (s,q) = get_string_utf8 v in
    wds s;
    match q with
      | Pair (Xml _ as x, q) -> print_elt [] x; print_content q
      | Atom a when a = Sequence.nil_atom -> ()
      | v -> schema_value ~wds v
  in
  document_start ();
  print_elt (Ns.Printer.prefixes printer) v;
  Buffer.contents buffer

let print_xml ~utf8 ns_table s =
  let s = string_of_xml ~utf8 ns_table s in
  if utf8 then string_utf8 (U.mk s) else string_latin1 s
 
1	abate	1536	(* Print XML documents *)
2	abate	77
3	abate	1536	(* The write__function are inspired from Pxp_aux.ml )
4
5			open Netconversion
6
7			let write_markup_string ~to_enc buf s =
8			let s' = if to_enc = `Enc_utf8 then s
9			else convert
10			~in_enc:`Enc_utf8
11			~out_enc:to_enc
12			~subst:(fun n ->
13			failwith ("Cannot represent code point " ^ string_of_int n))
14			s
15			in
16			Buffer.add_string buf s'
17
18			let write_data_string ~to_enc buf s =
19			let write_part i len =
20			if (len > 0) then
21			if to_enc = `Enc_utf8
22			then Buffer.add_substring buf s i len
23			else
24			let s' =
25			convert
26			~in_enc:`Enc_utf8
27			~out_enc:to_enc
28			~subst:(fun n -> "&#" ^ string_of_int n ^ ";")
29			~range_pos:i ~range_len:len s
30			in
31			Buffer.add_string buf s'
32			in
33			let i = ref 0 in
34			for k = 0 to String.length s - 1 do
35			match s.[k] with
36			\| ('&' \| '<' \| '>' \| '"' \| '%') as c ->
37			write_part !i (k - !i);
38			begin match c with
39			'&' -> Buffer.add_string buf "&"
40			\| '<' -> Buffer.add_string buf "<"
41			\| '>' -> Buffer.add_string buf ">"
42			\| '"' -> Buffer.add_string buf """
43			\| '%' -> Buffer.add_string buf "%" (* reserved in DTDs *)
44			\| _ -> assert false
45			end;
46			i := k+1
47			\| _ -> ()
48			done;
49			write_part !i (String.length s - !i)
50
51
52			(*************)
53
54
55	abate	77	open Value
56	abate	233	open Ident
57	abate	374	module U = Encodings.Utf8
58	abate	77
59	abate	78	let exn_print_xml = CDuceExn (Pair (
60	abate	656	Atom (Atoms.V.mk_ascii "Invalid_argument"),
61	abate	310	string_latin1 "print_xml"))
62	abate	77
63	abate	884	let blank = U.mk " "
64			let true_literal = U.mk "true"
65			let false_literal = U.mk "false"
66
67			(* @raise exn_print_xml in case of failure. Rationale: schema printing is
68			* the last attempt to print a value, others have already failed *)
69	abate	1490	let rec schema_value ?(recurs=true) ~wds v = match v with
70			\| Abstract ("float",f) ->
71			wds (U.mk (string_of_float (Obj.magic f : float)))
72	abate	884	\| Record _ as v ->
73			(try
74			wds (Schema_builtin.string_of_time_type (Value.get_fields v))
75	abate	1482	with Schema_builtin.Error _ -> raise exn_print_xml)
76	abate	884	\| Integer i -> wds (U.mk (Intervals.V.to_string i))
77			\| v when Value.equal v Value.vtrue -> wds true_literal
78			\| v when Value.equal v Value.vfalse -> wds false_literal
79			\| Pair _ as v when recurs -> schema_values ~wds v
80			\| String_utf8 _ as v -> wds (fst (get_string_utf8 v))
81			\| _ -> raise exn_print_xml
82
83			and schema_values ~wds v =
84			match v with
85			\| Pair (hd, Atom a) when a = Sequence.nil_atom ->
86			schema_value ~recurs:false ~wds hd
87			\| Pair (hd, tl) ->
88			schema_value ~recurs:false ~wds hd;
89			wds blank;
90			schema_values ~wds tl
91			\| _ -> raise exn_print_xml
92
93	abate	542	let string_of_xml ~utf8 ns_table v =
94	abate	375	let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
95	abate	77
96			let buffer = Buffer.create 127 in
97	abate	542	let printer = Ns.Printer.printer ns_table in
98	abate	77
99	abate	1536	let wms = write_markup_string ~to_enc buffer
100			and wds s = write_data_string ~to_enc buffer (U.get_str s)
101	abate	77	in
102	abate	542	let write_att (n,v) =
103			wms (" " ^ (Ns.Printer.attr printer n) ^ "=\""); wds v; wms "\"" in
104			let write_xmlns (pr,ns) =
105			let pr = U.get_str pr in
106			if pr = "" then wms " xmlns"
107			else (wms " xmlns:"; wms pr);
108			wms "=\"";
109			wds (Ns.value ns);
110			wms "\"" in
111	abate	884
112	abate	542	let element_start n xmlns attrs =
113			wms ("<" ^ (Ns.Printer.tag printer n));
114			List.iter write_xmlns xmlns;
115			List.iter write_att attrs;
116			wms ">"
117			and empty_element n xmlns attrs =
118			wms ("<" ^ (Ns.Printer.tag printer n));
119			List.iter write_xmlns xmlns;
120			List.iter write_att attrs;
121			wms "/>"
122			and element_end n =
123			wms ("</" ^ (Ns.Printer.attr printer n) ^ ">")
124	abate	77	and document_start () =
125	abate	126	(* wms ("<?xml version='1.0' encoding='" ^
126	abate	77	Netconversion.string_of_encoding to_enc ^
127	abate	126	"'?>\n") *)
128	abate	542	()
129	abate	374	in
130	abate	77
131	abate	542	let rec register_elt = function
132	abate	405	\| Xml (Atom tag, Record attrs, content) ->
133	abate	542	List.iter
134			(fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
135			(LabelMap.get attrs);
136	abate	656	Ns.Printer.register_tag printer (Atoms.V.value tag);
137	abate	542	register_content content
138			\| _ -> ()
139			and register_content = function
140			\| String_utf8 (_,_,_,q)
141			\| String_latin1 (_,_,_,q) -> register_content q
142			\| Pair (x, q) -> register_elt x; register_content q
143	abate	695	\| Concat (x,y) -> register_content x; register_content y
144	abate	542	\| _ -> ()
145			in
146			register_elt v;
147
148			let rec print_elt xmlns = function
149			\| Xml (Atom tag, Record attrs, content) ->
150	abate	656	let tag = Atoms.V.value tag in
151	abate	233	let attrs = LabelMap.mapi_to_list
152			(fun n v ->
153	abate	884	if is_str v then begin
154			let (s,q) = get_string_utf8 v in
155			match q with
156			\| Atom a when a = Sequence.nil_atom ->
157			(LabelPool.value n), s
158			\| _ -> raise exn_print_xml
159			end else begin
160			let buf = Buffer.create 20 in
161			let wds s = Buffer.add_string buf (U.get_str s) in
162			schema_value ~wds v;
163			(LabelPool.value n, U.mk (Buffer.contents buf))
164			end
165	abate	374	) attrs in
166	abate	172	(match content with
167	abate	542	\| Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
168	abate	172	\| _ ->
169	abate	542	element_start tag xmlns attrs;
170	abate	172	print_content content;
171			element_end tag)
172	abate	77	\| _ -> raise exn_print_xml
173	abate	374	and print_content v =
174			let (s,q) = get_string_utf8 v in
175			wds s;
176			match q with
177	abate	884	\| Pair (Xml _ as x, q) -> print_elt [] x; print_content q
178	abate	374	\| Atom a when a = Sequence.nil_atom -> ()
179	abate	884	\| v -> schema_value ~wds v
180	abate	77	in
181			document_start ();
182	abate	542	print_elt (Ns.Printer.prefixes printer) v;
183	abate	77	Buffer.contents buffer
184	abate	375
185	abate	542	let print_xml ~utf8 ns_table s =
186	abate	1536	let s = string_of_xml ~utf8 ns_table s in
187			if utf8 then string_utf8 (U.mk s) else string_latin1 s
188	abate	375