1 (***********************************************************************)
5 (* Kim Nguyen, LRI UMR8623 *)
6 (* Université Paris-Sud & CNRS *)
8 (* Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
9 (* Recherche Scientifique. All rights reserved. This file is *)
10 (* distributed under the terms of the GNU Lesser General Public *)
11 (* License, with the special exception on linking described in file *)
14 (***********************************************************************)
17 Time-stamp: <Last modified on 2013-03-09 18:49:04 CET by Kim Nguyen>
24 mutable data : string;
25 mutable first_child : node;
26 mutable next_sibling : node;
41 let dummy_tag = QName.of_string "#dummy"
54 (* TODO add other intersting stuff *)
63 mutable stack : node list;
64 text_buffer : Buffer.t;
65 mutable current_preorder : int;
68 let print_node_ptr fmt n =
69 Format.fprintf fmt "<%s>"
70 (if n == nil then "NIL" else
71 if n == dummy then "DUMMY" else
72 "NODE " ^ string_of_int n.preorder)
74 let debug_node fmt node =
75 Format.fprintf fmt "{ tag=%s; preorder=%i; data=%S; first_child=%a; next_sibling=%a; parent=%a }"
76 (QName.to_string node.tag)
79 print_node_ptr node.first_child
80 print_node_ptr node.next_sibling
81 print_node_ptr node.parent
84 let debug_ctx fmt ctx =
85 Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\n-------------\n"
87 (Pretty.print_list ~sep:";\n" debug_node) ctx.stack
90 let push n ctx = ctx.stack <- n :: ctx.stack
93 [] -> failwith "XML parse error"
94 | e :: l -> ctx.stack <- l; e
96 let top ctx = match ctx.stack with
97 | [] -> failwith "XML parse error"
101 let i = ctx.current_preorder in
102 ctx.current_preorder <- 1 + i;
105 let is_left n = n.next_sibling == dummy
108 let text_string = QName.to_string QName.text
109 let attr_map_string = QName.to_string QName.attribute_map
111 let att_pref = QName.node QName.attribute_prefix
112 let rec start_element_handler parser_ ctx tag attr_list =
114 let parent = top ctx in
115 let n = { tag = QName.of_string tag;
119 next_sibling = dummy;
123 if parent.first_child == dummy then parent.first_child <- n
124 else parent.next_sibling <- n;
126 List.iter (do_attribute parser_ ctx) attr_list
128 and do_attribute parser_ ctx (att, value) =
129 let att_tag = att_pref ^ att in
130 start_element_handler parser_ ctx att_tag [];
131 let n = top ctx in n.data <- value;
132 end_element_handler parser_ ctx att_tag
134 and consume_closing ctx n =
135 if n.next_sibling != dummy then
136 let _ = pop ctx in consume_closing ctx (top ctx)
138 and end_element_handler parser_ ctx _ =
140 let node = top ctx in
141 if node.first_child == dummy then node.first_child <- nil
143 node.next_sibling <- nil;
144 consume_closing ctx node
147 and do_text parser_ ctx =
148 if Buffer.length ctx.text_buffer != 0 then
149 let s = Buffer.contents ctx.text_buffer in
150 Buffer.clear ctx.text_buffer;
151 start_element_handler parser_ ctx text_string [];
152 let node = top ctx in
154 end_element_handler parser_ ctx text_string
158 let character_data_handler _parser ctx text =
159 Buffer.add_string ctx.text_buffer text
161 let create_parser () =
162 let ctx = { text_buffer = Buffer.create 512;
163 current_preorder = 0;
165 let parser_ = Expat.parser_create ~encoding:None in
166 Expat.set_start_element_handler parser_ (start_element_handler parser_ ctx);
167 Expat.set_end_element_handler parser_ (end_element_handler parser_ ctx);
168 Expat.set_character_data_handler parser_ (character_data_handler parser_ ctx);
169 push { tag = QName.document;
173 next_sibling = dummy;
178 let node = top ctx in
179 node.next_sibling <- nil;
180 consume_closing ctx node;
183 root.next_sibling <- nil;
185 | _ -> raise (Expat.Expat_error Expat.UNCLOSED_TOKEN)
190 let parser_, finalize = create_parser () in
191 Expat.parse parser_ s;
195 let buffer = String.create 4096 in
196 let parser_, finalize = create_parser () in
198 let read = input fd buffer 0 4096 in
200 let () = Expat.parse_sub parser_ buffer 0 read in
202 in loop (); finalize ()
207 let load_xml_file = Parser.parse_file
208 let load_xml_string = Parser.parse_string
211 let output_escape_string out s =
212 for i = 0 to String.length s - 1 do
214 | '<' -> output_string out "<"
215 | '>' -> output_string out ">"
216 | '&' -> output_string out "&"
217 | '"' -> output_string out """
218 | '\'' -> output_string out "'"
219 | c -> output_char out c
222 let rec print_attributes ?(sep=true) out tree_ node =
223 let tag = node.tag in
224 if QName.has_attribute_prefix tag then begin
225 let ntag = QName.node tag in
226 if sep then output_char out ' ';
227 output out ntag 1 (String.length ntag - 1);
228 output_string out "=\"";
229 output_escape_string out node.data;
231 print_attributes out tree_ node.next_sibling
236 let rec print_xml out tree_ node =
239 if node.tag == QName.text then
240 output_escape_string out node.data
242 let tag = QName.to_string node.tag in
244 output_string out tag;
245 let fchild = print_attributes out tree_ node.first_child in
246 if fchild == nil then output_string out "/>"
249 print_xml out tree_ fchild;
250 output_string out "</";
251 output_string out tag;
255 print_xml out tree_ node.next_sibling
257 let print_xml out tree_ node =
258 let nnode = { node with next_sibling = nil } in
259 if QName.has_attribute_prefix nnode.tag then
260 ignore (print_attributes ~sep:false out tree_ nnode)
262 print_xml out tree_ nnode
265 let first_child _ n = n.first_child
266 let next_sibling _ n = n.next_sibling
267 let parent _ n = n.parent
269 let data _ n = n.data
270 let preorder _ n = n.preorder
272 let print_node fmt n = Parser.debug_node fmt n