viewcvs.cgi/runtime/print_xml.ml

(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
open Value
open Ident

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

let to_enc = `Enc_iso88591

let string_of_xml v= 
  let buffer = Buffer.create 127 in

  let wms = 
    write_markup_string
      ~from_enc:`Enc_iso88591 
      ~to_enc
      (`Out_buffer buffer)

  and wds ?(from_enc=`Enc_iso88591) =
    write_data_string
      ~from_enc
      ~to_enc
      (`Out_buffer buffer)
  in
  let comment s = wms ("<!--" ^ s ^ "-->")
  and write_att (n,v) = wms (" " ^ n ^ "=\""); wds v; wms "\"" in
  let element_start name attrs = 
    wms ("<" ^ name); List.iter write_att attrs; wms ">"
  and empty_element name attrs = 
    wms ("<" ^ name); List.iter write_att attrs; wms "/>"
  and element_end name = wms ("</" ^ name ^ ">")
  and document_start () = 
(*    wms ("<?xml version='1.0' encoding='" ^
         Netconversion.string_of_encoding to_enc ^
         "'?>\n") *)
      ()
  and text s = wds s in

  let rec print_elt = function
    | Xml (Atom tag, Pair (Record attrs, content)) ->
        let tag = Atoms.value tag in
        let attrs = LabelMap.mapi_to_list 
                      (fun n v -> 
                         if not (is_str v) then raise exn_print_xml;
                         (LabelPool.value n,get_string_latin1 v)) attrs in
        (match content with
          | Atom a when a = Sequence.nil_atom -> empty_element tag attrs
          | _ ->
              element_start tag attrs;
              print_content content;
              element_end tag)
    | Char x ->
        wds (String.make 1 (Chars.to_char x)); (* TODO: opt *)
   | _ -> raise exn_print_xml
  and print_content = function
    | String_latin1 (i,j,s,q) ->
        wds (String.sub s i (j - i));
        print_content q
    | String_utf8 (i,j,s,q) ->
        wds ~from_enc:`Enc_utf8 (Encodings.Utf8.get_substr s i j);
        print_content q
    | Pair (elt, q) ->
        print_elt elt;
        print_content q
    | Atom a when a = Sequence.nil_atom -> true
    | _ -> raise exn_print_xml
  in
  document_start ();
  print_elt v;
  Buffer.contents buffer
1	(* Print XML documents, using PXP *)
2
3	open Pxp_aux
4	open Pxp_types
5	open Value
6	open Ident
7
8	let exn_print_xml = CDuceExn (Pair (
9	Atom (Atoms.mk "Invalid_argument"),
10	string_latin1 "print_xml"))
11
12	let to_enc = `Enc_iso88591
13
14	let string_of_xml v=
15	let buffer = Buffer.create 127 in
16
17	let wms =
18	write_markup_string
19	~from_enc:`Enc_iso88591
20	~to_enc
21	(`Out_buffer buffer)
22
23	and wds ?(from_enc=`Enc_iso88591) =
24	write_data_string
25	~from_enc
26	~to_enc
27	(`Out_buffer buffer)
28	in
29	let comment s = wms ("<!--" ^ s ^ "-->")
30	and write_att (n,v) = wms (" " ^ n ^ "=\""); wds v; wms "\"" in
31	let element_start name attrs =
32	wms ("<" ^ name); List.iter write_att attrs; wms ">"
33	and empty_element name attrs =
34	wms ("<" ^ name); List.iter write_att attrs; wms "/>"
35	and element_end name = wms ("</" ^ name ^ ">")
36	and document_start () =
37	(* wms ("<?xml version='1.0' encoding='" ^
38	Netconversion.string_of_encoding to_enc ^
39	"'?>\n") *)
40	()
41	and text s = wds s in
42
43	let rec print_elt = function
44	\| Xml (Atom tag, Pair (Record attrs, content)) ->
45	let tag = Atoms.value tag in
46	let attrs = LabelMap.mapi_to_list
47	(fun n v ->
48	if not (is_str v) then raise exn_print_xml;
49	(LabelPool.value n,get_string_latin1 v)) attrs in
50	(match content with
51	\| Atom a when a = Sequence.nil_atom -> empty_element tag attrs
52	\| _ ->
53	element_start tag attrs;
54	print_content content;
55	element_end tag)
56	\| Char x ->
57	wds (String.make 1 (Chars.to_char x)); (* TODO: opt *)
58	\| _ -> raise exn_print_xml
59	and print_content = function
60	\| String_latin1 (i,j,s,q) ->
61	wds (String.sub s i (j - i));
62	print_content q
63	\| String_utf8 (i,j,s,q) ->
64	wds ~from_enc:`Enc_utf8 (Encodings.Utf8.get_substr s i j);
65	print_content q
66	\| Pair (elt, q) ->
67	print_elt elt;
68	print_content q
69	\| Atom a when a = Sequence.nil_atom -> true
70	\| _ -> raise exn_print_xml
71	in
72	document_start ();
73	print_elt v;
74	Buffer.contents buffer