--- /dev/null
+type +'a jvm_pointer
+
+external dereference_object : 'a jvm_pointer -> unit = "dereference_object"
+external get_null : unit -> 'a jvm_pointer = "getNull"
+
+let null = get_null ()
+
+module Java_tree : sig
+ include Tree.S
+ val init_document : node -> int -> t
+end =
+ struct
+
+ type node = [`Node] jvm_pointer
+
+ type named_node_map = [`NamedNodeMap] jvm_pointer
+
+
+
+ external dereference_node : node -> unit = "dereference_object"
+ external dereference_named_node_map : named_node_map -> unit = "dereference_object"
+
+ external node_get_preorder : node -> int = "node_getPreorder"
+
+
+ external node_set_preorder : node -> int -> unit = "node_setPreorder"
+
+
+ external node_get_owner_element : node -> node = "attr_getOwnerElement"
+
+
+ external node_get_attributes : node -> named_node_map = "node_getAttributes"
+
+
+ external named_node_map_get_length : named_node_map -> int = "namednodemap_getLength"
+
+
+
+
+
+ external named_node_map_item : named_node_map -> int -> node = "namednodemap_item"
+
+
+
+
+ type t = {
+ root : node;
+ size : int;
+ tag_cache : QName.t array
+ }
+
+ let nil = get_null ()
+
+ let dummy = get_null ()
+
+ let size t = t.size
+
+ let load_xml_file _ = assert false
+ let load_xml_string _ = assert false
+ let print_xml _ _ _ = assert false
+ let root t = t.root
+
+
+
+ external node_get_node_type : node -> int = "node_getNodeType"
+
+ let node_kind_of_int i =
+ Tree.NodeKind.(
+ match i with
+ | 1 -> Element
+ | 2 -> Attribute
+ | 3 | 4 -> Text
+ | 7 -> ProcessingInstruction
+ | 8 -> Comment
+ | 9 -> Document
+ | _ -> failwith ("Unimplemented document kind, please report " ^ string_of_int i)
+ )
+
+
+ external node_get_node_name : node -> string = "node_getNodeName"
+
+ let kind _ node =
+ assert (node != null);
+ node_kind_of_int (node_get_node_type node)
+
+ external node_get_first_child : node -> node = "node_getFirstChild"
+
+ external print_runtime_class : 'a jvm_pointer -> unit = "print_runtime_class"
+ let first_child _ node =
+ if node == nil then nil else
+ let attrs = node_get_attributes node in
+ if attrs == null then
+ node_get_first_child node
+ else
+ let len = named_node_map_get_length attrs in
+ if len == 0 (* possible ? *) then node_get_first_child node else
+ let at = named_node_map_item attrs 0 in
+ at
+
+ external node_get_next_sibling : node -> node = "node_getNextSibling"
+
+
+ let next_sibling tree node =
+
+ if node == nil then nil else
+ if (kind tree node) == Tree.NodeKind.Attribute then
+ begin
+
+ let owner = node_get_owner_element node in
+ let own_pre = node_get_preorder owner in
+ let node_pre = node_get_preorder node in
+ let attrs = node_get_attributes owner in
+ let len = named_node_map_get_length attrs in
+ let i = node_pre - own_pre / 2 in
+ if i < len then named_node_map_item attrs i else
+ node_get_first_child owner
+ end
+ else node_get_next_sibling node
+
+ let parent _ _ = assert false
+
+ let data _ _ = assert false
+
+ let tag tree node =
+ if node == nil then QName.nil else
+ let pre = node_get_preorder node in
+ let label = tree.tag_cache.(pre) in
+ if label != QName.nil then label else
+ let label = node_get_node_name node in
+ let rlabel =
+ Tree.NodeKind.(
+ match kind tree node with
+ | Document -> QName.document
+ | Text -> QName.text
+ | Attribute -> QName.attribute (QName.of_string label)
+ | ProcessingInstruction ->
+ QName.processing_instruction (QName.of_string label)
+ | _ -> QName.of_string label
+ )
+ in
+ tree.tag_cache.(pre) <- rlabel; rlabel
+
+ let preorder tree node =
+ if node == nil then -1 else
+ node_get_preorder node
+
+ let finalize t =
+ dereference_object (t.root)
+
+ let init_document node i =
+ let s = { size = i;
+ root = node;
+ tag_cache = Array.create i QName.nil
+ }
+ in
+ Gc.finalise (finalize) s;
+ s
+
+
+ let print_node _ _ = assert false
+ let by_preorder _ _ = assert false
+ end
+
+
+module Java_node_list : Node_list.S with type node = Java_tree.node
+ =
+ struct
+ type node = Java_tree.node
+ type node_list = [`NodeList] jvm_pointer
+ type t = node_list
+ external length : node_list -> int = "nodelist_getLength"
+ external create : unit -> node_list = "nodelist_new"
+ external add : node_list -> node -> node_list = "nodelist_add"
+ external item : node_list -> int -> node = "nodelist_item"
+
+ let add n l =
+ add l n
+
+ let iter f l =
+ for i = 0 to length l - 1 do
+ f (item l i)
+ done
+
+ end
+
+module Runtime = Run.Make(Java_tree)(Java_node_list)
+
+let _ = Callback.register "init_document" Java_tree.init_document
+
+let xpath_compile p =
+ let auto =
+ Xpath.Compile.path
+ (Xpath.Parser.parse (Ulexing.from_utf8_string p))
+ in
+ Ata.print Format.err_formatter auto;
+ Format.pp_print_flush Format.err_formatter ();
+ auto
+
+let _ = Callback.register "xpath_compile" xpath_compile
+
+let auto_evaluate auto tree list =
+ Runtime.eval auto tree list
+
+let _ = Callback.register "auto_evaluate" auto_evaluate