src/bindings/java/tatoo_driver.ml

   1 type +'a jvm_pointer
   2
   3 external dereference_object : 'a jvm_pointer -> unit = "dereference_object"
   4 external get_null : unit -> 'a jvm_pointer = "getNull"
   5
   6 let null = get_null ()
   7
   8 module Java_tree : sig
   9   include Tree.S
  10   val init_document : node -> int -> t
  11 end =
  12   struct
  13
  14     type node = [`Node] jvm_pointer
  15
  16     type named_node_map = [`NamedNodeMap] jvm_pointer
  17
  18
  19
  20     external dereference_node : node -> unit = "dereference_object"
  21     external dereference_named_node_map : named_node_map -> unit = "dereference_object"
  22
  23     external node_get_preorder : node -> int = "node_getPreorder"
  24
  25
  26     external node_set_preorder : node -> int -> unit = "node_setPreorder"
  27
  28
  29     external node_get_owner_element : node -> node = "attr_getOwnerElement"
  30
  31
  32     external node_get_attributes : node -> named_node_map = "node_getAttributes"
  33
  34
  35     external named_node_map_get_length : named_node_map -> int = "namednodemap_getLength"
  36
  37
  38
  39
  40
  41     external named_node_map_item : named_node_map -> int -> node = "namednodemap_item"
  42
  43
  44
  45
  46     type t = {
  47       root  : node;
  48       size : int;
  49       tag_cache : QName.t array
  50     }
  51
  52     let nil = get_null ()
  53
  54     let dummy = get_null ()
  55
  56     let size t = t.size
  57
  58     let load_xml_file _ = assert false
  59     let load_xml_string _ = assert false
  60     let print_xml _ _ _ = assert false
  61     let root t = t.root
  62
  63
  64
  65     external node_get_node_type : node -> int = "node_getNodeType"
  66
  67     let node_kind_of_int i =
  68       Tree.NodeKind.(
  69         match i with
  70         | 1 -> Element
  71         | 2 -> Attribute
  72         | 3 | 4 -> Text
  73         | 7 -> ProcessingInstruction
  74         | 8 -> Comment
  75         | 9 -> Document
  76         | _ -> failwith ("Unimplemented document kind, please report " ^ string_of_int i)
  77       )
  78
  79
  80     external node_get_node_name : node -> string = "node_getNodeName"
  81
  82     let kind _ node =
  83       assert (node != null);
  84       node_kind_of_int (node_get_node_type node)
  85
  86     external node_get_first_child : node -> node = "node_getFirstChild"
  87
  88     external print_runtime_class : 'a jvm_pointer -> unit = "print_runtime_class"
  89     let first_child _ node =
  90       if node == nil then nil else
  91         let attrs = node_get_attributes node in
  92         if attrs == null then
  93           node_get_first_child node
  94         else
  95           let len = named_node_map_get_length attrs in
  96           if len == 0 (* possible ? *) then node_get_first_child node else
  97             let at = named_node_map_item attrs 0 in
  98             at
  99
 100     external node_get_next_sibling : node -> node = "node_getNextSibling"
 101
 102
 103     let next_sibling tree node =
 104
 105       if node == nil then nil else
 106         if  (kind tree node) == Tree.NodeKind.Attribute then
 107           begin
 108
 109             let owner = node_get_owner_element node in
 110             let own_pre = node_get_preorder owner in
 111             let node_pre =  node_get_preorder node in
 112             let attrs = node_get_attributes owner in
 113             let len =  named_node_map_get_length attrs in
 114             let i = node_pre - own_pre / 2 in
 115             if i < len then named_node_map_item attrs i else
 116               node_get_first_child owner
 117           end
 118         else node_get_next_sibling node
 119
 120     let parent _ _ = assert false
 121
 122     let data _ _  = assert false
 123
 124     let tag tree node =
 125       if node == nil then QName.nil else
 126         let pre = node_get_preorder node in
 127         let label = tree.tag_cache.(pre) in
 128         if label  != QName.nil then label else
 129           let label = node_get_node_name node in
 130           let rlabel =
 131           Tree.NodeKind.(
 132             match kind tree node with
 133             | Document -> QName.document
 134             | Text -> QName.text
 135             | Attribute -> QName.attribute (QName.of_string label)
 136             | ProcessingInstruction ->
 137               QName.processing_instruction  (QName.of_string label)
 138             | _ ->  QName.of_string label
 139           )
 140           in
 141           tree.tag_cache.(pre) <- rlabel; rlabel
 142
 143     let preorder tree node =
 144       if node == nil then -1 else
 145         node_get_preorder node
 146
 147     let finalize t =
 148       dereference_object (t.root)
 149
 150     let init_document node i =
 151       let s = { size = i;
 152                 root = node;
 153                 tag_cache = Array.create i QName.nil
 154               }
 155       in
 156       Gc.finalise (finalize) s;
 157       s
 158
 159
 160     let print_node _ _ = assert false
 161     let by_preorder _ _ = assert false
 162   end
 163
 164
 165 module Java_node_list : Node_list.S with type node = Java_tree.node
 166   =
 167   struct
 168     type node = Java_tree.node
 169     type node_list = [`NodeList] jvm_pointer
 170     type t = node_list
 171     external length : node_list -> int = "nodelist_getLength"
 172     external create : unit -> node_list = "nodelist_new"
 173     external add : node_list -> node -> node_list = "nodelist_add"
 174     external item : node_list -> int -> node = "nodelist_item"
 175
 176     let add n l =
 177       add l n
 178
 179     let iter f l =
 180       for i = 0 to length l - 1 do
 181         f (item l i)
 182       done
 183
 184   end
 185
 186 module Runtime = Run.Make(Java_tree)(Java_node_list)
 187
 188 let _ = Callback.register "init_document" Java_tree.init_document
 189
 190 let xpath_compile p =
 191   let auto =
 192      Xpath.Compile.path
 193        (Xpath.Parser.parse (Ulexing.from_utf8_string p))
 194   in
 195   Ata.print Format.err_formatter auto;
 196   Format.pp_print_flush Format.err_formatter ();
 197   auto
 198
 199 let _ = Callback.register "xpath_compile" xpath_compile
 200
 201 let auto_evaluate  auto tree list =
 202   Runtime.eval auto tree list
 203
 204 let _ = Callback.register "auto_evaluate" auto_evaluate