X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=src%2Ftree.ml;h=587e649261b305a0d3d5a7c9aae954eb703a9713;hb=a47ebfed7e88a701a3345be1bda3c25fd81195a3;hp=27ceed6492ad3ba103dac086d7b68115dcfa22c3;hpb=4b52da1a20a4fe031930bb96d2ca46bec06dc529;p=SXSI%2Fxpathcomp.git diff --git a/src/tree.ml b/src/tree.ml index 27ceed6..587e649 100644 --- a/src/tree.ml +++ b/src/tree.ml @@ -8,7 +8,7 @@ INCLUDE "debug.ml" INCLUDE "utils.ml" -external init_lib : unit -> unit = "caml_init_lib" +external init_lib : unit -> unit = "sxsi_cpp_init" exception CPlusPlusError of string @@ -20,6 +20,127 @@ type node = [ `Tree ] Node.t type tree + +external register_tag : tree -> string -> Tag.t = "caml_xml_tree_register_tag" + +external tag_name : tree -> Tag.t -> string = "caml_xml_tree_get_tag_name" + +let tag t = (); fun s -> + match s with + | "<$>" -> Tag.pcdata + | "<@>" -> Tag.attribute + | "" -> Tag.document_node + | "<@$>" -> Tag.attribute_data + | _ -> register_tag t s + +let to_string d = (); + fun t -> + if t == Tag.pcdata then "<$>" + else if t == Tag.attribute_data then "<@$>" + else if t == Tag.attribute then "<@>" + else if t == Tag.nullt then "" + else tag_name d t + +let translate x = x + +let mk_tag_ops t = { + Tag.tag = tag t; + Tag.to_string = to_string t; + Tag.translate = translate +} + +module TreeBuilder = +struct + type t + external create : unit -> t = "caml_xml_tree_builder_create" + external open_document : t -> bool -> int -> bool -> int -> unit = "caml_xml_tree_builder_open_document" + external close_document : t -> tree = "caml_xml_tree_builder_close_document" + external open_tag : t -> string -> unit = "caml_xml_tree_builder_new_open_tag" + external close_tag : t -> string -> unit = "caml_xml_tree_builder_new_closing_tag" + external text : t -> string -> unit = "caml_xml_tree_builder_new_text" + + + let do_text b t = + if Buffer.length t > 0 then begin + open_tag b "<$>"; + text b (Buffer.contents t); + close_tag b "<$>"; + Buffer.clear t + end + + let output_attr b name value = + let atname = "<@>" ^ name in + open_tag b atname; + open_tag b "<@$>"; + text b value; + close_tag b "<@$>"; + close_tag b atname + + let start_element_handler b t tag attr_list = + do_text b t; + open_tag b tag; + match attr_list with + [] -> () + | l -> + open_tag b "<@>"; + List.iter (fun (name, value) -> output_attr b name value) l; + close_tag b "<@>" + + + let end_element_handler b t tag = + do_text b t; + close_tag b tag + + let character_data_handler _b t text = + Buffer.add_string t text + + let create_parser () = + let buf = Buffer.create 512 in + let build = create () in + let parser_ = Expat.parser_create ~encoding:None in + let finalize () = + do_text build buf; + close_tag build ""; + close_document build + in + Expat.set_start_element_handler parser_ (start_element_handler build buf); + Expat.set_end_element_handler parser_ (end_element_handler build buf); + Expat.set_character_data_handler parser_ (character_data_handler build buf); + open_document build !Options.index_empty_texts !Options.sample_factor + !Options.disable_text_collection !Options.text_index_type; + open_tag build ""; + parser_, finalize + + let parse_string s = + let parser_, finalizer = create_parser () in + Expat.parse parser_ s; + finalizer () + + let parse_file file = + let in_chan = open_in file in + let buffer = String.create 4096 in + let parser_, finalizer = create_parser () in + let () = + try + while true do + let read = input in_chan buffer 0 4096 in + if read == 0 then raise End_of_file else + Expat.parse_sub parser_ buffer 0 read; + done + + with + | End_of_file -> close_in in_chan + | e -> raise e + in + finalizer () + + + +end + + + + type bit_vector = string external bool_of_int : int -> bool = "%identity" @@ -40,9 +161,11 @@ type t = { } - +let tag_operations t = mk_tag_ops t.doc +(* external parse_xml_uri : string -> int -> bool -> bool -> int -> tree = "caml_call_shredder_uri" external parse_xml_string : string -> int -> bool -> bool -> int -> tree = "caml_call_shredder_string" +*) external tree_print_xml_fast3 : tree -> [`Tree ] Node.t -> Unix.file_descr -> unit = "caml_xml_tree_print" let print_xml t n fd = tree_print_xml_fast3 t.doc n fd @@ -105,6 +228,9 @@ let next_sibling t n = tree_next_sibling t.doc n external tree_next_element : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_element" "noalloc" let next_element t n = tree_next_element t.doc n +external tree_next_node_before : tree -> [`Tree] Node.t -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_node_before" "noalloc" +let next_node_before t n ctx = tree_next_node_before t.doc n ctx + external tree_tagged_following_sibling : tree -> [`Tree] Node.t -> Tag.t -> [`Tree] Node.t = "caml_xml_tree_tagged_following_sibling" "noalloc" let tagged_following_sibling t n tag = tree_tagged_following_sibling t.doc n tag @@ -119,6 +245,9 @@ let prev_sibling t n = tree_prev_sibling t.doc n external tree_tagged_descendant : tree -> [`Tree ] Node.t -> Tag.t -> [`Tree ] Node.t = "caml_xml_tree_tagged_descendant" "noalloc" let tagged_descendant t n tag = tree_tagged_descendant t.doc n tag +external tree_tagged_next : tree -> [`Tree ] Node.t -> Tag.t -> [`Tree ] Node.t = "caml_xml_tree_tagged_next" "noalloc" +let tagged_next t n tag = tree_tagged_next t.doc n tag + external tree_select_descendant : tree -> [`Tree ] Node.t -> unordered_set -> [`Tree] Node.t = "caml_xml_tree_select_descendant" "noalloc" let select_descendant t n tag_set = tree_select_descendant t.doc n tag_set @@ -392,7 +521,7 @@ let is_node t = t != nil let is_root t = t == root let node_of_t t = - let _ = Tag.init (Obj.magic t) in + let _ = Tag.init (mk_tag_ops t) in let f, n, c, d = time collect_labels t ~msg:"Building tag relationship table" in let c = Array.map TagS.to_ptset c in let n = Array.map TagS.to_ptset n in @@ -415,21 +544,12 @@ let node_of_t t = } -let parse f str = - node_of_t - (f str !Options.sample_factor - !Options.index_empty_texts - !Options.disable_text_collection - !Options.text_index_type - ) -let parse_xml_uri str = parse parse_xml_uri str -let parse_xml_string str = parse parse_xml_string str +let parse_xml_uri str = node_of_t (TreeBuilder.parse_file str) +let parse_xml_string str = node_of_t (TreeBuilder.parse_string str) let size t = tree_size t.doc;; -external pool : tree -> Tag.pool = "%identity" - let magic_string = "SXSI_INDEX" let version_string = "3" @@ -521,8 +641,6 @@ let load ?(sample=64) ?(load_text=true) str = -let tag_pool t = pool t.doc - let equal a b = a == b let nts = function