viewcvs.cgi/runtime/print_xml.ml

(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
open Value

let exn_print_xml = CDuceExn (Pair (
                                Atom (Types.AtomPool.mk "Invalid_argument"),
                                string "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 =
    write_data_string
      ~from_enc:`Enc_iso88591 
      ~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 = Types.AtomPool.value tag in
        let attrs = List.map (fun (n,v) -> 
                       if not (is_str v) then raise exn_print_xml;
                       (Types.LabelPool.value n,get_string 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.Unichar.to_char x)); (* TODO: opt *)
   | _ -> raise exn_print_xml
  and print_content = function
    | String (i,j,s,q) ->
        wds (String.sub s i (j - i));
        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	abate	77	(* Print XML documents, using PXP *)
2
3			open Pxp_aux
4			open Pxp_types
5			open Value
6
7	abate	78	let exn_print_xml = CDuceExn (Pair (
8			Atom (Types.AtomPool.mk "Invalid_argument"),
9			string "print_xml"))
10	abate	77
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 =
24			write_data_string
25			~from_enc:`Enc_iso88591
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	abate	183	wms ("<" ^ name); List.iter write_att attrs; wms ">"
33	abate	172	and empty_element name attrs =
34			wms ("<" ^ name); List.iter write_att attrs; wms "/>"
35	abate	183	and element_end name = wms ("</" ^ name ^ ">")
36	abate	77	and document_start () =
37	abate	126	(* wms ("<?xml version='1.0' encoding='" ^
38	abate	77	Netconversion.string_of_encoding to_enc ^
39	abate	126	"'?>\n") *)
40			()
41	abate	77	and text s = wds s in
42
43			let rec print_elt = function
44	abate	123	\| Xml (Atom tag, Pair (Record attrs, content)) ->
45	abate	78	let tag = Types.AtomPool.value tag in
46	abate	172	let attrs = List.map (fun (n,v) ->
47	abate	77	if not (is_str v) then raise exn_print_xml;
48	abate	172	(Types.LabelPool.value n,get_string v)) attrs in
49			(match content with
50			\| Atom a when a = Sequence.nil_atom -> empty_element tag attrs
51			\| _ ->
52			element_start tag attrs;
53			print_content content;
54			element_end tag)
55	abate	77	\| Char x ->
56			wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
57			\| _ -> raise exn_print_xml
58			and print_content = function
59			\| String (i,j,s,q) ->
60			wds (String.sub s i (j - i));
61			print_content q
62			\| Pair (elt, q) ->
63			print_elt elt;
64			print_content q
65			\| Atom a when a = Sequence.nil_atom -> true
66			\| _ -> raise exn_print_xml
67			in
68			document_start ();
69			print_elt v;
70			Buffer.contents buffer