viewcvs.cgi/runtime/print_xml.ml

(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
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
  | Record _ as v ->
      (try
        wds (Schema_builtin.string_of_time_type (Value.get_fields v))
      with Schema_builtin.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
      ~from_enc:`Enc_utf8 
      ~to_enc
      (`Out_buffer buffer)

  and wds s =
    write_data_string
      ~from_enc:`Enc_utf8
      ~to_enc
      (`Out_buffer 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 =
  try   
    let s = string_of_xml ~utf8 ns_table 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))
 
1	abate	77	(* Print XML documents, using PXP *)
2
3			open Pxp_aux
4			open Pxp_types
5			open Value
6	abate	233	open Ident
7	abate	374	module U = Encodings.Utf8
8	abate	77
9	abate	78	let exn_print_xml = CDuceExn (Pair (
10	abate	656	Atom (Atoms.V.mk_ascii "Invalid_argument"),
11	abate	310	string_latin1 "print_xml"))
12	abate	77
13	abate	884	let blank = U.mk " "
14			let true_literal = U.mk "true"
15			let false_literal = U.mk "false"
16
17			(* @raise exn_print_xml in case of failure. Rationale: schema printing is
18			* the last attempt to print a value, others have already failed *)
19			let rec schema_value ?(recurs=true) ~wds v =
20			match v with
21			\| Record _ as v ->
22			(try
23			wds (Schema_builtin.string_of_time_type (Value.get_fields v))
24			with Schema_builtin.Schema_builtin_error _ -> raise exn_print_xml)
25			\| Integer i -> wds (U.mk (Intervals.V.to_string i))
26			\| v when Value.equal v Value.vtrue -> wds true_literal
27			\| v when Value.equal v Value.vfalse -> wds false_literal
28			\| Pair _ as v when recurs -> schema_values ~wds v
29			\| String_utf8 _ as v -> wds (fst (get_string_utf8 v))
30			\| _ -> raise exn_print_xml
31
32			and schema_values ~wds v =
33			match v with
34			\| Pair (hd, Atom a) when a = Sequence.nil_atom ->
35			schema_value ~recurs:false ~wds hd
36			\| Pair (hd, tl) ->
37			schema_value ~recurs:false ~wds hd;
38			wds blank;
39			schema_values ~wds tl
40			\| _ -> raise exn_print_xml
41
42	abate	542	let string_of_xml ~utf8 ns_table v =
43	abate	375	let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
44	abate	77
45			let buffer = Buffer.create 127 in
46	abate	542	let printer = Ns.Printer.printer ns_table in
47	abate	77
48			let wms =
49			write_markup_string
50	abate	374	~from_enc:`Enc_utf8
51	abate	77	~to_enc
52			(`Out_buffer buffer)
53
54	abate	374	and wds s =
55	abate	77	write_data_string
56	abate	374	~from_enc:`Enc_utf8
57	abate	77	~to_enc
58			(`Out_buffer buffer)
59	abate	374	(U.get_str s)
60	abate	77	in
61	abate	542	let write_att (n,v) =
62			wms (" " ^ (Ns.Printer.attr printer n) ^ "=\""); wds v; wms "\"" in
63			let write_xmlns (pr,ns) =
64			let pr = U.get_str pr in
65			if pr = "" then wms " xmlns"
66			else (wms " xmlns:"; wms pr);
67			wms "=\"";
68			wds (Ns.value ns);
69			wms "\"" in
70	abate	884
71	abate	542	let element_start n xmlns attrs =
72			wms ("<" ^ (Ns.Printer.tag printer n));
73			List.iter write_xmlns xmlns;
74			List.iter write_att attrs;
75			wms ">"
76			and empty_element n xmlns attrs =
77			wms ("<" ^ (Ns.Printer.tag printer n));
78			List.iter write_xmlns xmlns;
79			List.iter write_att attrs;
80			wms "/>"
81			and element_end n =
82			wms ("</" ^ (Ns.Printer.attr printer n) ^ ">")
83	abate	77	and document_start () =
84	abate	126	(* wms ("<?xml version='1.0' encoding='" ^
85	abate	77	Netconversion.string_of_encoding to_enc ^
86	abate	126	"'?>\n") *)
87	abate	542	()
88	abate	374	in
89	abate	77
90	abate	542	let rec register_elt = function
91	abate	405	\| Xml (Atom tag, Record attrs, content) ->
92	abate	542	List.iter
93			(fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
94			(LabelMap.get attrs);
95	abate	656	Ns.Printer.register_tag printer (Atoms.V.value tag);
96	abate	542	register_content content
97			\| _ -> ()
98			and register_content = function
99			\| String_utf8 (_,_,_,q)
100			\| String_latin1 (_,_,_,q) -> register_content q
101			\| Pair (x, q) -> register_elt x; register_content q
102	abate	695	\| Concat (x,y) -> register_content x; register_content y
103	abate	542	\| _ -> ()
104			in
105			register_elt v;
106
107			let rec print_elt xmlns = function
108			\| Xml (Atom tag, Record attrs, content) ->
109	abate	656	let tag = Atoms.V.value tag in
110	abate	233	let attrs = LabelMap.mapi_to_list
111			(fun n v ->
112	abate	884	if is_str v then begin
113			let (s,q) = get_string_utf8 v in
114			match q with
115			\| Atom a when a = Sequence.nil_atom ->
116			(LabelPool.value n), s
117			\| _ -> raise exn_print_xml
118			end else begin
119			let buf = Buffer.create 20 in
120			let wds s = Buffer.add_string buf (U.get_str s) in
121			schema_value ~wds v;
122			(LabelPool.value n, U.mk (Buffer.contents buf))
123			end
124	abate	374	) attrs in
125	abate	172	(match content with
126	abate	542	\| Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
127	abate	172	\| _ ->
128	abate	542	element_start tag xmlns attrs;
129	abate	172	print_content content;
130			element_end tag)
131	abate	77	\| _ -> raise exn_print_xml
132	abate	374	and print_content v =
133			let (s,q) = get_string_utf8 v in
134			wds s;
135			match q with
136	abate	884	\| Pair (Xml _ as x, q) -> print_elt [] x; print_content q
137	abate	374	\| Atom a when a = Sequence.nil_atom -> ()
138	abate	884	\| v -> schema_value ~wds v
139	abate	77	in
140			document_start ();
141	abate	542	print_elt (Ns.Printer.prefixes printer) v;
142	abate	77	Buffer.contents buffer
143	abate	375
144	abate	542	let print_xml ~utf8 ns_table s =
145	abate	375	try
146	abate	542	let s = string_of_xml ~utf8 ns_table s in
147	abate	375	if utf8 then string_utf8 (U.mk s) else string_latin1 s
148			with exn ->
149			raise
150			(Location.Generic (Pxp_types.string_of_exn exn))
151