src/bindings/c++/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
  17     external dereference_node : node -> unit = "dereference_object"
  18
  19     external node_get_preorder : node -> int = "node_getPreorder"
  20
  21
  22     (*external node_set_preorder : node -> int -> unit = "node_setPreorder"*)
  23
  24
  25     type t = {
  26       root  : node;
  27       size : int;
  28       tag_cache : QName.t array
  29     }
  30
  31     let nil = get_null ()
  32
  33     let dummy = get_null ()
  34
  35     let size t = t.size
  36
  37     let load_xml_file _ = assert false
  38     let load_xml_string _ = assert false
  39     let print_xml _ _ _ = assert false
  40     let root t = t.root
  41
  42
  43
  44     external node_get_node_type : node -> int = "node_getNodeType"
  45
  46     let node_kind_of_int i =
  47       Tree.NodeKind.(
  48         match i with
  49         | 1 -> Element
  50         | 2 -> Attribute
  51         | 3 | 4 -> Text
  52         | 7 -> ProcessingInstruction
  53         | 8 -> Comment
  54         | 9 -> Document
  55         | _ -> failwith ("Unimplemented document kind, please report " ^ string_of_int i)
  56       )
  57
  58
  59     external node_get_node_name : node -> string = "node_getNodeName"
  60
  61     let kind _ node =
  62       assert (node != null);
  63       node_kind_of_int (node_get_node_type node)
  64
  65     external node_get_first_child : node -> node = "node_getFirstChild"
  66
  67     let first_child _ node =
  68       if node == nil then nil else
  69         node_get_first_child node
  70
  71     external node_get_next_sibling : node -> node = "node_getNextSibling"
  72
  73
  74     let next_sibling tree node =
  75
  76       if node == nil then nil else
  77         node_get_next_sibling node
  78
  79     let parent _ _ = assert false
  80
  81     let data _ _  = assert false
  82
  83     let tag tree node =
  84       if node == nil then QName.nil else
  85         let pre = node_get_preorder node in
  86         let label = tree.tag_cache.(pre) in
  87         if label  != QName.nil then label else
  88           let label = node_get_node_name node in
  89           let rlabel =
  90           Tree.NodeKind.(
  91             match kind tree node with
  92             | Document -> QName.document
  93             | Text -> QName.text
  94             | Attribute -> QName.attribute (QName.of_string label)
  95             | ProcessingInstruction ->
  96               QName.processing_instruction  (QName.of_string label)
  97             | _ ->  QName.of_string label
  98           )
  99           in
 100           tree.tag_cache.(pre) <- rlabel; rlabel
 101
 102     let preorder tree node =
 103       if node == nil then -1 else
 104         node_get_preorder node
 105
 106     let finalize t =
 107       dereference_object (t.root)
 108
 109     let init_document node i =
 110       let s = { size = i;
 111                 root = node;
 112                 tag_cache = Array.create i QName.nil
 113               }
 114       in
 115       Gc.finalise (finalize) s;
 116       s
 117
 118
 119     let print_node _ _ = assert false
 120     let by_preorder _ _ = assert false
 121   end
 122
 123
 124 module Java_node_list : Node_list.S with type node = Java_tree.node
 125   =
 126   struct
 127     type node = Java_tree.node
 128     type node_list = [`NodeList] jvm_pointer
 129     type t = node_list
 130     external length : node_list -> int = "nodelist_getLength"
 131     external create : unit -> node_list = "nodelist_new"
 132     external add : node_list -> node -> node_list = "nodelist_add"
 133     external item : node_list -> int -> node = "nodelist_item"
 134
 135     let add n l =
 136       add l n
 137
 138     let iter f l =
 139       for i = 0 to length l - 1 do
 140         f (item l i)
 141       done
 142
 143   end
 144
 145 module Runtime = Run.Make(Java_tree)(Java_node_list)
 146
 147 let _ = Callback.register "init_document" Java_tree.init_document
 148
 149 let xpath_compile p =
 150   let auto =
 151      Xpath.Compile.path
 152        (Xpath.Parser.parse (Ulexing.from_utf8_string p))
 153   in
 154   Ata.print Format.err_formatter auto;
 155   Format.pp_print_flush Format.err_formatter ();
 156   auto
 157
 158 let _ = Callback.register "xpath_compile" xpath_compile
 159
 160 let auto_evaluate  auto tree list =
 161   Runtime.eval auto tree list
 162
 163 let _ = Callback.register "auto_evaluate" auto_evaluate