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 "\n>"
  and element_end name = wms ("</" ^ name ^ "\n>")
  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
    | Pair (Atom tag, Pair (Record attrs, content)) ->
        let tag = Types.AtomPool.value tag in
        element_start tag
          (List.map (fun (n,v) -> 
                       if not (is_str v) then raise exn_print_xml;
                       (Types.LabelPool.value n,get_string v)) 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			wms ("<" ^ name); List.iter write_att attrs; wms "\n>"
33			and element_end name = wms ("</" ^ name ^ "\n>")
34			and document_start () =
35			wms ("<?xml version='1.0' encoding='" ^
36			Netconversion.string_of_encoding to_enc ^
37			"'?>\n")
38			and text s = wds s in
39
40			let rec print_elt = function
41			\| Pair (Atom tag, Pair (Record attrs, content)) ->
42	abate	78	let tag = Types.AtomPool.value tag in
43	abate	77	element_start tag
44			(List.map (fun (n,v) ->
45			if not (is_str v) then raise exn_print_xml;
46	abate	78	(Types.LabelPool.value n,get_string v)) attrs);
47	abate	77	print_content content;
48			element_end tag
49			\| Char x ->
50			wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
51			\| _ -> raise exn_print_xml
52			and print_content = function
53			\| String (i,j,s,q) ->
54			wds (String.sub s i (j - i));
55			print_content q
56			\| Pair (elt, q) ->
57			print_elt elt;
58			print_content q
59			\| Atom a when a = Sequence.nil_atom -> true
60			\| _ -> raise exn_print_xml
61			in
62			document_start ();
63			print_elt v;
64			Buffer.contents buffer