+++ /dev/null
-(***********************************************************************)
-(* *)
-(* TAToo *)
-(* *)
-(* Kim Nguyen, LRI UMR8623 *)
-(* Université Paris-Sud & CNRS *)
-(* *)
-(* Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
-(* Recherche Scientifique. All rights reserved. This file is *)
-(* distributed under the terms of the GNU Lesser General Public *)
-(* License, with the special exception on linking described in file *)
-(* ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(*
- Time-stamp: <Last modified on 2013-03-13 18:47:18 CET by Kim Nguyen>
-*)
-open Utils
-
-type node = {
- tag : QName.t;
- preorder : int;
- mutable kind : Common.NodeKind.t;
- mutable data : string;
- mutable first_child : node;
- mutable next_sibling : node;
- mutable parent: node;
-}
-
-
-
-let rec nil = {
- tag = QName.nil;
- kind = Common.NodeKind.Element;
- preorder = -1;
- data = "";
- first_child = nil;
- next_sibling = nil;
- parent = nil;
-}
-
-let dummy_tag = QName.of_string "#dummy"
-let rec dummy = {
- tag = dummy_tag;
- kind = Common.NodeKind.Element;
- preorder = -1;
- data = "";
- first_child = dummy;
- next_sibling = dummy;
- parent = dummy;
-}
-
-
-type t = {
- root : node;
- size : int;
- (* TODO add other intersting stuff *)
-}
-
-
-
-module Parser =
-struct
-
- type context = {
- mutable stack : node list;
- text_buffer : Buffer.t;
- mutable current_preorder : int;
- }
-
- let print_node_ptr fmt n =
- Format.fprintf fmt "<%s>"
- (if n == nil then "NIL" else
- if n == dummy then "DUMMY" else
- "NODE " ^ string_of_int n.preorder)
-
- let debug_node fmt node =
- Format.fprintf fmt "{ tag=%s; preorder=%i; data=%S; first_child=%a; next_sibling=%a; parent=%a }"
- (QName.to_string node.tag)
- node.preorder
- node.data
- print_node_ptr node.first_child
- print_node_ptr node.next_sibling
- print_node_ptr node.parent
-
-
- let debug_ctx fmt ctx =
- Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\n-------------\n"
- ctx.current_preorder
- (Pretty.print_list ~sep:";\n" debug_node) ctx.stack
-
-
- let push n ctx = ctx.stack <- n :: ctx.stack
- let pop ctx =
- match ctx.stack with
- [] -> failwith "XML parse error"
- | e :: l -> ctx.stack <- l; e
-
- let top ctx = match ctx.stack with
- | [] -> failwith "XML parse error"
- | e :: _ -> e
-
- let next ctx =
- let i = ctx.current_preorder in
- ctx.current_preorder <- 1 + i;
- i
-
- let is_left n = n.next_sibling == dummy
-
-
- let text_string = QName.to_string QName.text
- let comment_string = QName.to_string QName.comment
-
-
- let rec start_element_handler parser_ ctx tag attr_list =
- do_text parser_ ctx;
- let parent = top ctx in
- let n = { tag = QName.of_string tag;
- kind = Common.NodeKind.Element;
- preorder = next ctx;
- data = "";
- first_child = dummy;
- next_sibling = dummy;
- parent = parent;
- }
- in
- if parent.first_child == dummy then parent.first_child <- n
- else parent.next_sibling <- n;
- push n ctx;
- List.iter (do_attribute parser_ ctx) attr_list
-
- and do_attribute parser_ ctx (att, value) =
- let att_tag = QName.to_string (QName.attribute (QName.of_string att)) in
- start_element_handler parser_ ctx att_tag [];
- let n = top ctx in
- n.data <- value;
- n.kind <- Common.NodeKind.Attribute;
- end_element_handler parser_ ctx att_tag
-
- and consume_closing ctx n =
- if n.next_sibling != dummy then
- let _ = pop ctx in consume_closing ctx (top ctx)
-
- and end_element_handler parser_ ctx _ =
- do_text parser_ ctx;
- let node = top ctx in
- if node.first_child == dummy then node.first_child <- nil
- else begin
- node.next_sibling <- nil;
- consume_closing ctx node
- end
-
- and do_text parser_ ctx =
- if Buffer.length ctx.text_buffer != 0 then
- let s = Buffer.contents ctx.text_buffer in
- Buffer.clear ctx.text_buffer;
- start_element_handler parser_ ctx text_string [];
- let node = top ctx in
- node.data <- s;
- node.kind <- Common.NodeKind.Text;
- end_element_handler parser_ ctx text_string
-
- and comment_handler parser_ ctx s =
- do_text parser_ ctx;
- start_element_handler parser_ ctx comment_string [];
- let node = top ctx in
- node.data <- s;
- node.kind <- Common.NodeKind.Comment;
- end_element_handler parser_ ctx comment_string
-
- and processing_instruction_handler parser_ ctx tag data =
- do_text parser_ ctx;
- let pi = QName.to_string
- (QName.processing_instruction (QName.of_string tag))
- in
- start_element_handler parser_ ctx pi [];
- let node = top ctx in
- node.data <- data;
- node.kind <- Common.NodeKind.ProcessingInstruction;
- end_element_handler parser_ ctx pi
-
-
- let character_data_handler _parser ctx text =
- Buffer.add_string ctx.text_buffer text
-
- let create_parser () =
- let ctx = { text_buffer = Buffer.create 512;
- current_preorder = 0;
- stack = [] } in
- let psr = Expat.parser_create ~encoding:None in
- Expat.set_start_element_handler psr (start_element_handler psr ctx);
- Expat.set_end_element_handler psr (end_element_handler psr ctx);
- Expat.set_character_data_handler
- psr (character_data_handler psr ctx);
- Expat.set_comment_handler psr (comment_handler psr ctx);
- Expat.set_processing_instruction_handler psr
- (processing_instruction_handler psr ctx);
- push { tag = QName.document;
- preorder = next ctx;
- kind = Common.NodeKind.Document;
- data = "";
- first_child = dummy;
- next_sibling = dummy;
- parent = nil;
- } ctx;
- (psr,
- fun () ->
- let node = top ctx in
- node.next_sibling <- nil;
- consume_closing ctx node;
- match ctx.stack with
- [ root ] ->
- root.next_sibling <- nil;
- { root = root;
- size = ctx.current_preorder
- }
- | _ -> raise (Expat.Expat_error Expat.UNCLOSED_TOKEN)
- )
-
-
- let parse_string s =
- let parser_, finalize = create_parser () in
- Expat.parse parser_ s;
- finalize ()
-
- let parse_file fd =
- let buffer = String.create 4096 in
- let parser_, finalize = create_parser () in
- let rec loop () =
- let read = input fd buffer 0 4096 in
- if read != 0 then
- let () = Expat.parse_sub parser_ buffer 0 read in
- loop ()
- in loop (); finalize ()
-
-end
-
-
-let load_xml_file = Parser.parse_file
-let load_xml_string = Parser.parse_string
-
-let output_escape_string out s =
- for i = 0 to String.length s - 1 do
- match s.[i] with
- | '<' -> output_string out "<"
- | '>' -> output_string out ">"
- | '&' -> output_string out "&"
- | '"' -> output_string out """
- | '\'' -> output_string out "'"
- | c -> output_char out c
- done
-
-
-let rec print_attributes ?(sep=true) out tree_ node =
- if (node.kind == Common.NodeKind.Attribute) then
- let tag = QName.to_string (QName.remove_prefix node.tag) in
- if sep then output_char out ' ';
- output_string out tag;
- output_string out "=\"";
- output_escape_string out node.data;
- output_char out '\"';
- print_attributes out tree_ node.next_sibling
- else
- node
-
-let rec print_xml out tree_ node =
- if node != nil then
- let () =
- let open Common.NodeKind in
- match node.kind with
- | Node -> ()
- | Text -> output_escape_string out node.data
- | Element | Document ->
- let tag = QName.to_string node.tag in
- output_char out '<';
- output_string out tag;
- let fchild = print_attributes out tree_ node.first_child in
- if fchild == nil then output_string out "/>"
- else begin
- output_char out '>';
- print_xml out tree_ fchild;
- output_string out "</";
- output_string out tag;
- output_char out '>'
- end
- | Attribute -> ignore (print_attributes ~sep:false out tree_ node)
- | Comment ->
- output_string out "<!--";
- output_string out node.data;
- output_string out "-->"
- | ProcessingInstruction ->
- output_string out "<?";
- output_string out (QName.to_string (QName.remove_prefix node.tag));
- output_char out ' ';
- output_string out node.data;
- output_string out "?>"
- in
- print_xml out tree_ node.next_sibling
-
-let print_xml out tree_ node =
- let nnode = { node with next_sibling = nil } in print_xml out tree_ nnode
-
-let root t = t.root
-let size t = t.size
-let first_child _ n = n.first_child
-let next_sibling _ n = n.next_sibling
-let parent _ n = n.parent
-let tag _ n = n.tag
-let data _ n = n.data
-let kind _ n = n.kind
-let preorder _ n = n.preorder
-
-let print_node fmt n = Parser.debug_node fmt n
projects / tatoo.git / blobdiff