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-02-05 13:56:52 CET by Kim Nguyễn>
23 mutable data : string;
24 mutable first_child : node;
25 mutable next_sibling : node;
40 let dummy_tag = QName.of_string "#dummy"
53 (* TODO add other intersting stuff *)
62 mutable stack : node list;
63 text_buffer : Buffer.t;
64 mutable current_preorder : int;
67 let print_node_ptr fmt n =
68 Format.fprintf fmt "<%s>"
69 (if n == nil then "NIL" else
70 if n == dummy then "DUMMY" else
71 "NODE " ^ string_of_int n.preorder)
73 let debug_node fmt node =
74 Format.fprintf fmt "{ tag=%s; preorder=%i; data=%s; first_child=%a; next_sibling=%a; parent=%a }"
75 (QName.to_string node.tag)
78 print_node_ptr node.first_child
79 print_node_ptr node.next_sibling
80 print_node_ptr node.parent
83 let debug_ctx fmt ctx =
84 Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\n-------------\n"
86 (Pretty.print_list ~sep:";\n" debug_node) ctx.stack
89 let push n ctx = ctx.stack <- n :: ctx.stack
92 [] -> failwith "XML parse error"
93 | e :: l -> ctx.stack <- l; e
95 let top ctx = match ctx.stack with
96 | [] -> failwith "XML parse error"
100 let i = ctx.current_preorder in
101 ctx.current_preorder <- 1 + i;
104 let is_left n = n.next_sibling == dummy
107 let text_string = QName.to_string QName.text
108 let attr_map_string = QName.to_string QName.attribute_map
110 let rec start_element_handler parser_ ctx tag attr_list =
112 let parent = top ctx in
113 let n = { tag = QName.of_string tag;
117 next_sibling = dummy;
121 if parent.first_child == dummy then parent.first_child <- n
122 else parent.next_sibling <- n;
127 start_element_handler parser_ ctx attr_map_string [];
128 List.iter (do_attribute parser_ ctx) attr_list;
129 end_element_handler parser_ ctx attr_map_string
131 and do_attribute parser_ ctx (att, value) =
132 let att_tag = " " ^ att in
133 start_element_handler parser_ ctx att_tag [];
134 start_element_handler parser_ ctx text_string [];
135 let n = top ctx in n.data <- value;
136 end_element_handler parser_ ctx text_string;
137 end_element_handler parser_ ctx att_tag
139 and consume_closing ctx n =
140 if n.next_sibling != dummy then
141 let _ = pop ctx in consume_closing ctx (top ctx)
143 and end_element_handler parser_ ctx tag =
145 let node = top ctx in
146 if node.first_child == dummy then node.first_child <- nil
148 node.next_sibling <- nil;
149 consume_closing ctx node
152 and do_text parser_ ctx =
153 if Buffer.length ctx.text_buffer != 0 then
154 let s = Buffer.contents ctx.text_buffer in
155 Buffer.clear ctx.text_buffer;
156 start_element_handler parser_ ctx text_string [];
157 let node = top ctx in
159 end_element_handler parser_ ctx text_string
163 let character_data_handler parser_ ctx text =
164 Buffer.add_string ctx.text_buffer text
166 let create_parser () =
167 let ctx = { text_buffer = Buffer.create 512;
168 current_preorder = 0;
170 let parser_ = Expat.parser_create ~encoding:None in
171 Expat.set_start_element_handler parser_ (start_element_handler parser_ ctx);
172 Expat.set_end_element_handler parser_ (end_element_handler parser_ ctx);
173 Expat.set_character_data_handler parser_ (character_data_handler parser_ ctx);
174 push { tag = QName.document;
178 next_sibling = dummy;
183 let node = top ctx in
184 node.next_sibling <- nil;
185 consume_closing ctx node;
188 root.next_sibling <- nil;
190 | _ -> raise (Expat.Expat_error Expat.UNCLOSED_TOKEN)
195 let parser_, finalize = create_parser () in
196 Expat.parse parser_ s;
200 let buffer = String.create 4096 in
201 let parser_, finalize = create_parser () in
203 let read = input fd buffer 0 4096 in
205 let () = Expat.parse_sub parser_ buffer 0 read in
207 in loop (); finalize ()
212 let load_xml_file = Parser.parse_file
213 let load_xml_string = Parser.parse_string
216 let output_escape_string out s =
217 for i = 0 to String.length s - 1 do
219 | '<' -> output_string out "<"
220 | '>' -> output_string out ">"
221 | '&' -> output_string out "&"
222 | '"' -> output_string out """
223 | '\'' -> output_string out "'"
224 | c -> output_char out c
227 let rec print_attributes out tree_ node =
228 if node != nil then begin
229 output_string out (QName.to_string node.tag);
230 output_string out "=\"";
231 output_escape_string out node.first_child.data;
233 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;
246 if node.first_child.tag == QName.attribute_map then
248 print_attributes out tree_ node.first_child.first_child
250 node.first_child.next_sibling
254 if fchild == nil then output_string out "/>"
257 print_xml out tree_ fchild;
258 output_string out "</";
259 output_string out tag;
263 print_xml out tree_ node.next_sibling
267 let first_child _ n = n.first_child
268 let next_sibling _ n = n.next_sibling
269 let parent _ n = n.parent
271 let data _ n = n.data
272 let preorder _ n = n.preorder