|
|
ffd6ed |
From cf3b6c9450c252fd16774e606b03c1730c216a18 Mon Sep 17 00:00:00 2001
|
|
|
ffd6ed |
From: "Richard W.M. Jones" <rjones@redhat.com>
|
|
|
ffd6ed |
Date: Thu, 25 Jun 2015 18:00:02 +0100
|
|
|
ffd6ed |
Subject: [PATCH] v2v: Free XML objects in the correct order.
|
|
|
ffd6ed |
|
|
|
ffd6ed |
If you free an xmlDocPtr before any xmlXPathObjectPtrs that reference
|
|
|
ffd6ed |
the doc, you'll get valgrind errors like this:
|
|
|
ffd6ed |
|
|
|
ffd6ed |
==7390== Invalid read of size 4
|
|
|
ffd6ed |
==7390== at 0x4EB8BC6: xmlXPathFreeNodeSet (xpath.c:4185)
|
|
|
ffd6ed |
==7390== by 0x4EB8CC5: xmlXPathFreeObject (xpath.c:5492)
|
|
|
ffd6ed |
==7390== by 0x400A56: main (in /tmp/test)
|
|
|
ffd6ed |
==7390== Address 0x60c0928 is 8 bytes inside a block of size 120 free'd
|
|
|
ffd6ed |
==7390== at 0x4C29D2A: free (in /usr/lib64/valgrind/vgpreload_memcheck-amd64-linux.so)
|
|
|
ffd6ed |
==7390== by 0x4E8784F: xmlFreeNodeList (tree.c:3683)
|
|
|
ffd6ed |
==7390== by 0x4E87605: xmlFreeDoc (tree.c:1242)
|
|
|
ffd6ed |
==7390== by 0x400A4A: main (in /tmp/test)
|
|
|
ffd6ed |
|
|
|
ffd6ed |
The following simple test program demonstrates the problem:
|
|
|
ffd6ed |
|
|
|
ffd6ed |
#include <stdio.h>
|
|
|
ffd6ed |
#include <stdlib.h>
|
|
|
ffd6ed |
#include <assert.h>
|
|
|
ffd6ed |
#include <libxml/xpath.h>
|
|
|
ffd6ed |
|
|
|
ffd6ed |
int
|
|
|
ffd6ed |
main (int argc, char *argv[])
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
xmlDocPtr doc;
|
|
|
ffd6ed |
xmlXPathContextPtr xpathctx;
|
|
|
ffd6ed |
xmlXPathObjectPtr xpathobj;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
doc = xmlReadMemory ("<test/>", 7, NULL, NULL, XML_PARSE_NONET);
|
|
|
ffd6ed |
assert (doc);
|
|
|
ffd6ed |
xpathctx = xmlXPathNewContext (doc);
|
|
|
ffd6ed |
assert (xpathctx);
|
|
|
ffd6ed |
xpathobj = xmlXPathEvalExpression (BAD_CAST "/test", xpathctx);
|
|
|
ffd6ed |
assert (xpathobj);
|
|
|
ffd6ed |
xmlFreeDoc (doc);
|
|
|
ffd6ed |
xmlXPathFreeObject (xpathobj);
|
|
|
ffd6ed |
xmlXPathFreeContext (xpathctx);
|
|
|
ffd6ed |
exit (EXIT_SUCCESS);
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
In virt-v2v we were not freeing up objects in the correct order,
|
|
|
ffd6ed |
because we didn't express the dependency between objects at the C
|
|
|
ffd6ed |
level into the OCaml, where the OCaml garbage collector could see
|
|
|
ffd6ed |
those dependencies. For example code like:
|
|
|
ffd6ed |
|
|
|
ffd6ed |
let doc = ... in
|
|
|
ffd6ed |
let xpathctx = xpath_new_context doc in
|
|
|
ffd6ed |
let xpathobj = xpath_eval_expression xpathctx "/foo" in
|
|
|
ffd6ed |
|
|
|
ffd6ed |
might end up freeing the 'doc' (xmlDocPtr) if, say, there were no
|
|
|
ffd6ed |
further references to it in the code, even though the 'xpathobj'
|
|
|
ffd6ed |
(xmlXPathObjectPtr) remains live.
|
|
|
ffd6ed |
|
|
|
ffd6ed |
To avoid this, we change the OCaml-level representation of objects
|
|
|
ffd6ed |
like xpathobj so they contain a reference back to the higher-level
|
|
|
ffd6ed |
objects (xpathctx & doc). Therefore holding an xpathobj means that
|
|
|
ffd6ed |
the doc cannot be freed.
|
|
|
ffd6ed |
|
|
|
ffd6ed |
However that alone is not quite sufficient. There is a further
|
|
|
ffd6ed |
problem when the program calls Gc.full_major, Gc.compact etc., or even
|
|
|
ffd6ed |
just when xpathctx & doc happen to be freed at the same time. The GC
|
|
|
ffd6ed |
won't necessarily free them in the right order as it knows both need
|
|
|
ffd6ed |
to be freed but doesn't know that one must be freed before the other.
|
|
|
ffd6ed |
|
|
|
ffd6ed |
To solve this we have to move the finalisers into OCaml code, since
|
|
|
ffd6ed |
the OCaml Gc.finalise function comes with an explicit ordering
|
|
|
ffd6ed |
guarantee (that finalisers are always called in reverse order that
|
|
|
ffd6ed |
they were created), which the C-level finaliser does not.
|
|
|
ffd6ed |
|
|
|
ffd6ed |
(cherry picked from commit 3888582da89c757d0740d11c3a62433d748c85aa)
|
|
|
ffd6ed |
---
|
|
|
ffd6ed |
v2v/input_libvirtxml.ml | 18 ++++-----
|
|
|
ffd6ed |
v2v/input_ova.ml | 10 ++---
|
|
|
ffd6ed |
v2v/output_libvirt.ml | 6 +--
|
|
|
ffd6ed |
v2v/xml-c.c | 103 +++++++++++++++++++++++++-----------------------
|
|
|
ffd6ed |
v2v/xml.ml | 77 ++++++++++++++++++++++++------------
|
|
|
ffd6ed |
v2v/xml.mli | 2 +-
|
|
|
ffd6ed |
6 files changed, 123 insertions(+), 93 deletions(-)
|
|
|
ffd6ed |
|
|
|
ffd6ed |
diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml
|
|
|
ffd6ed |
index 0f21bb3..16c34a6 100644
|
|
|
ffd6ed |
--- a/v2v/input_libvirtxml.ml
|
|
|
ffd6ed |
+++ b/v2v/input_libvirtxml.ml
|
|
|
ffd6ed |
@@ -44,14 +44,14 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.node_as_string node
|
|
|
ffd6ed |
)
|
|
|
ffd6ed |
and xpath_to_int expr default =
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
let str = Xml.node_as_string node in
|
|
|
ffd6ed |
try int_of_string str
|
|
|
ffd6ed |
with Failure "int_of_string" ->
|
|
|
ffd6ed |
@@ -76,7 +76,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx "/domain/features/*" in
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
features := Xml.node_name node :: !features
|
|
|
ffd6ed |
done;
|
|
|
ffd6ed |
!features in
|
|
|
ffd6ed |
@@ -87,7 +87,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
if nr_nodes < 1 then None
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
(* Ignore everything except the first <graphics> device. *)
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
let keymap =
|
|
|
ffd6ed |
match xpath_to_string "@keymap" "" with "" -> None | k -> Some k in
|
|
|
ffd6ed |
@@ -148,7 +148,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
if nr_nodes < 1 then None
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
(* Ignore everything except the first <sound> device. *)
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
match xpath_to_string "@model" "" with
|
|
|
ffd6ed |
@@ -187,7 +187,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
if nr_nodes < 1 then
|
|
|
ffd6ed |
error (f_"this guest has no non-removable disks");
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
let controller =
|
|
|
ffd6ed |
@@ -250,7 +250,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.node_as_string node
|
|
|
ffd6ed |
) in
|
|
|
ffd6ed |
|
|
|
ffd6ed |
@@ -281,7 +281,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
let disks = ref [] in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
let controller =
|
|
|
ffd6ed |
@@ -311,7 +311,7 @@ let parse_libvirt_xml ?conn ~verbose xml =
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
let nics = ref [] in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
let mac = xpath_to_string "mac/@address" "" in
|
|
|
ffd6ed |
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
|
|
|
ffd6ed |
index 8deedda..ab8c27b 100644
|
|
|
ffd6ed |
--- a/v2v/input_ova.ml
|
|
|
ffd6ed |
+++ b/v2v/input_ova.ml
|
|
|
ffd6ed |
@@ -184,14 +184,14 @@ object
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.node_as_string node
|
|
|
ffd6ed |
)
|
|
|
ffd6ed |
and xpath_to_int expr default =
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
let str = Xml.node_as_string node in
|
|
|
ffd6ed |
try int_of_string str
|
|
|
ffd6ed |
with Failure "int_of_string" ->
|
|
|
ffd6ed |
@@ -247,7 +247,7 @@ object
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let n = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let n = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx n;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
(* XXX We assume the OVF lists these in order.
|
|
|
ffd6ed |
@@ -316,7 +316,7 @@ object
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let n = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let n = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx n;
|
|
|
ffd6ed |
let id = xpath_to_int "rasd:ResourceType/text()" 0 in
|
|
|
ffd6ed |
assert (id = 14 || id = 15 || id = 16);
|
|
|
ffd6ed |
@@ -350,7 +350,7 @@ object
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx "/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/ovf:Item[rasd:ResourceType/text()=10]" in
|
|
|
ffd6ed |
let nr_nodes = Xml.xpathobj_nr_nodes obj in
|
|
|
ffd6ed |
for i = 0 to nr_nodes-1 do
|
|
|
ffd6ed |
- let n = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let n = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx n;
|
|
|
ffd6ed |
let vnet = xpath_to_string "rasd:ElementName/text()" (sprintf"eth%d" i) in
|
|
|
ffd6ed |
let nic = {
|
|
|
ffd6ed |
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
|
|
|
ffd6ed |
index 23e881a..6188aa6 100644
|
|
|
ffd6ed |
--- a/v2v/output_libvirt.ml
|
|
|
ffd6ed |
+++ b/v2v/output_libvirt.ml
|
|
|
ffd6ed |
@@ -52,7 +52,7 @@ let target_features_of_capabilities_doc doc arch =
|
|
|
ffd6ed |
warning ~prog (f_"the target hypervisor does not support a %s KVM guest") arch;
|
|
|
ffd6ed |
[]
|
|
|
ffd6ed |
) else (
|
|
|
ffd6ed |
- let node (* first matching <guest> *) = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node (* first matching <guest> *) = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.xpathctx_set_current_context xpathctx node;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
(* Get guest/features/* nodes. *)
|
|
|
ffd6ed |
@@ -60,7 +60,7 @@ let target_features_of_capabilities_doc doc arch =
|
|
|
ffd6ed |
|
|
|
ffd6ed |
let features = ref [] in
|
|
|
ffd6ed |
for i = 0 to Xml.xpathobj_nr_nodes obj - 1 do
|
|
|
ffd6ed |
- let feature_node = Xml.xpathobj_node doc obj i in
|
|
|
ffd6ed |
+ let feature_node = Xml.xpathobj_node obj i in
|
|
|
ffd6ed |
let feature_name = Xml.node_name feature_node in
|
|
|
ffd6ed |
features := feature_name :: !features
|
|
|
ffd6ed |
done;
|
|
|
ffd6ed |
@@ -355,7 +355,7 @@ class output_libvirt verbose oc output_pool = object
|
|
|
ffd6ed |
let obj = Xml.xpath_eval_expression xpathctx expr in
|
|
|
ffd6ed |
if Xml.xpathobj_nr_nodes obj < 1 then default
|
|
|
ffd6ed |
else (
|
|
|
ffd6ed |
- let node = Xml.xpathobj_node doc obj 0 in
|
|
|
ffd6ed |
+ let node = Xml.xpathobj_node obj 0 in
|
|
|
ffd6ed |
Xml.node_as_string node
|
|
|
ffd6ed |
)
|
|
|
ffd6ed |
in
|
|
|
ffd6ed |
diff --git a/v2v/xml-c.c b/v2v/xml-c.c
|
|
|
ffd6ed |
index 0b619e5..c71ab24 100644
|
|
|
ffd6ed |
--- a/v2v/xml-c.c
|
|
|
ffd6ed |
+++ b/v2v/xml-c.c
|
|
|
ffd6ed |
@@ -42,60 +42,53 @@
|
|
|
ffd6ed |
/* xmlDocPtr type */
|
|
|
ffd6ed |
#define Doc_val(v) (*((xmlDocPtr *)Data_custom_val(v)))
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-static void
|
|
|
ffd6ed |
-doc_finalize (value docv)
|
|
|
ffd6ed |
-{
|
|
|
ffd6ed |
- xmlDocPtr doc = Doc_val (docv);
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
- if (doc)
|
|
|
ffd6ed |
- xmlFreeDoc (doc);
|
|
|
ffd6ed |
-}
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
static struct custom_operations doc_custom_operations = {
|
|
|
ffd6ed |
(char *) "doc_custom_operations",
|
|
|
ffd6ed |
- doc_finalize,
|
|
|
ffd6ed |
+ custom_finalize_default,
|
|
|
ffd6ed |
custom_compare_default,
|
|
|
ffd6ed |
custom_hash_default,
|
|
|
ffd6ed |
custom_serialize_default,
|
|
|
ffd6ed |
custom_deserialize_default
|
|
|
ffd6ed |
};
|
|
|
ffd6ed |
|
|
|
ffd6ed |
+value
|
|
|
ffd6ed |
+v2v_xml_free_doc_ptr (value docv)
|
|
|
ffd6ed |
+{
|
|
|
ffd6ed |
+ CAMLparam1 (docv);
|
|
|
ffd6ed |
+ xmlDocPtr doc = Doc_val (docv);
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+ xmlFreeDoc (doc);
|
|
|
ffd6ed |
+ CAMLreturn (Val_unit);
|
|
|
ffd6ed |
+}
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
/* xmlXPathContextPtr type */
|
|
|
ffd6ed |
-#define Xpathctx_val(v) (*((xmlXPathContextPtr *)Data_custom_val(v)))
|
|
|
ffd6ed |
+#define Xpathctx_ptr_val(v) (*((xmlXPathContextPtr *)Data_custom_val(v)))
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-static void
|
|
|
ffd6ed |
-xpathctx_finalize (value xpathctxv)
|
|
|
ffd6ed |
-{
|
|
|
ffd6ed |
- xmlXPathContextPtr xpathctx = Xpathctx_val (xpathctxv);
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
- if (xpathctx)
|
|
|
ffd6ed |
- xmlXPathFreeContext (xpathctx);
|
|
|
ffd6ed |
-}
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
-static struct custom_operations xpathctx_custom_operations = {
|
|
|
ffd6ed |
- (char *) "xpathctx_custom_operations",
|
|
|
ffd6ed |
- xpathctx_finalize,
|
|
|
ffd6ed |
+static struct custom_operations xpathctx_ptr_custom_operations = {
|
|
|
ffd6ed |
+ (char *) "xpathctx_ptr_custom_operations",
|
|
|
ffd6ed |
+ custom_finalize_default,
|
|
|
ffd6ed |
custom_compare_default,
|
|
|
ffd6ed |
custom_hash_default,
|
|
|
ffd6ed |
custom_serialize_default,
|
|
|
ffd6ed |
custom_deserialize_default
|
|
|
ffd6ed |
};
|
|
|
ffd6ed |
|
|
|
ffd6ed |
+value
|
|
|
ffd6ed |
+v2v_xml_free_xpathctx_ptr (value xpathctxv)
|
|
|
ffd6ed |
+{
|
|
|
ffd6ed |
+ CAMLparam1 (xpathctxv);
|
|
|
ffd6ed |
+ xmlXPathContextPtr xpathctx = Xpathctx_ptr_val (xpathctxv);
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+ xmlXPathFreeContext (xpathctx);
|
|
|
ffd6ed |
+ CAMLreturn (Val_unit);
|
|
|
ffd6ed |
+}
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
/* xmlXPathObjectPtr type */
|
|
|
ffd6ed |
-#define Xpathobj_val(v) (*((xmlXPathObjectPtr *)Data_custom_val(v)))
|
|
|
ffd6ed |
+#define Xpathobj_ptr_val(v) (*((xmlXPathObjectPtr *)Data_custom_val(v)))
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-static void
|
|
|
ffd6ed |
-xpathobj_finalize (value xpathobjv)
|
|
|
ffd6ed |
-{
|
|
|
ffd6ed |
- xmlXPathObjectPtr xpathobj = Xpathobj_val (xpathobjv);
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
- if (xpathobj)
|
|
|
ffd6ed |
- xmlXPathFreeObject (xpathobj);
|
|
|
ffd6ed |
-}
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
-static struct custom_operations xpathobj_custom_operations = {
|
|
|
ffd6ed |
- (char *) "xpathobj_custom_operations",
|
|
|
ffd6ed |
- xpathobj_finalize,
|
|
|
ffd6ed |
+static struct custom_operations xpathobj_ptr_custom_operations = {
|
|
|
ffd6ed |
+ (char *) "xpathobj_ptr_custom_operations",
|
|
|
ffd6ed |
+ custom_finalize_default,
|
|
|
ffd6ed |
custom_compare_default,
|
|
|
ffd6ed |
custom_hash_default,
|
|
|
ffd6ed |
custom_serialize_default,
|
|
|
ffd6ed |
@@ -103,6 +96,16 @@ static struct custom_operations xpathobj_custom_operations = {
|
|
|
ffd6ed |
};
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
+v2v_xml_free_xpathobj_ptr (value xpathobjv)
|
|
|
ffd6ed |
+{
|
|
|
ffd6ed |
+ CAMLparam1 (xpathobjv);
|
|
|
ffd6ed |
+ xmlXPathObjectPtr xpathobj = Xpathobj_ptr_val (xpathobjv);
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+ xmlXPathFreeObject (xpathobj);
|
|
|
ffd6ed |
+ CAMLreturn (Val_unit);
|
|
|
ffd6ed |
+}
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+value
|
|
|
ffd6ed |
v2v_xml_parse_memory (value xmlv)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam1 (xmlv);
|
|
|
ffd6ed |
@@ -124,7 +127,7 @@ v2v_xml_parse_memory (value xmlv)
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
-v2v_xml_xpath_new_context (value docv)
|
|
|
ffd6ed |
+v2v_xml_xpath_new_context_ptr (value docv)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam1 (docv);
|
|
|
ffd6ed |
CAMLlocal1 (xpathctxv);
|
|
|
ffd6ed |
@@ -136,21 +139,21 @@ v2v_xml_xpath_new_context (value docv)
|
|
|
ffd6ed |
if (xpathctx == NULL)
|
|
|
ffd6ed |
caml_invalid_argument ("xpath_new_context: unable to create xmlXPathNewContext");
|
|
|
ffd6ed |
|
|
|
ffd6ed |
- xpathctxv = caml_alloc_custom (&xpathctx_custom_operations,
|
|
|
ffd6ed |
+ xpathctxv = caml_alloc_custom (&xpathctx_ptr_custom_operations,
|
|
|
ffd6ed |
sizeof (xmlXPathContextPtr), 0, 1);
|
|
|
ffd6ed |
- Xpathctx_val (xpathctxv) = xpathctx;
|
|
|
ffd6ed |
+ Xpathctx_ptr_val (xpathctxv) = xpathctx;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
CAMLreturn (xpathctxv);
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
-v2v_xml_xpath_register_ns (value xpathctxv, value prefix, value uri)
|
|
|
ffd6ed |
+v2v_xml_xpathctx_ptr_register_ns (value xpathctxv, value prefix, value uri)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam3 (xpathctxv, prefix, uri);
|
|
|
ffd6ed |
xmlXPathContextPtr xpathctx;
|
|
|
ffd6ed |
int r;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
- xpathctx = Xpathctx_val (xpathctxv);
|
|
|
ffd6ed |
+ xpathctx = Xpathctx_ptr_val (xpathctxv);
|
|
|
ffd6ed |
r = xmlXPathRegisterNs (xpathctx, BAD_CAST String_val (prefix), BAD_CAST String_val (uri));
|
|
|
ffd6ed |
if (r == -1)
|
|
|
ffd6ed |
caml_invalid_argument ("xpath_register_ns: unable to register namespace");
|
|
|
ffd6ed |
@@ -159,30 +162,30 @@ v2v_xml_xpath_register_ns (value xpathctxv, value prefix, value uri)
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
-v2v_xml_xpath_eval_expression (value xpathctxv, value exprv)
|
|
|
ffd6ed |
+v2v_xml_xpathctx_ptr_eval_expression (value xpathctxv, value exprv)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam2 (xpathctxv, exprv);
|
|
|
ffd6ed |
CAMLlocal1 (xpathobjv);
|
|
|
ffd6ed |
xmlXPathContextPtr xpathctx;
|
|
|
ffd6ed |
xmlXPathObjectPtr xpathobj;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
- xpathctx = Xpathctx_val (xpathctxv);
|
|
|
ffd6ed |
+ xpathctx = Xpathctx_ptr_val (xpathctxv);
|
|
|
ffd6ed |
xpathobj = xmlXPathEvalExpression (BAD_CAST String_val (exprv), xpathctx);
|
|
|
ffd6ed |
if (xpathobj == NULL)
|
|
|
ffd6ed |
caml_invalid_argument ("xpath_eval_expression: unable to evaluate XPath expression");
|
|
|
ffd6ed |
|
|
|
ffd6ed |
- xpathobjv = caml_alloc_custom (&xpathobj_custom_operations,
|
|
|
ffd6ed |
+ xpathobjv = caml_alloc_custom (&xpathobj_ptr_custom_operations,
|
|
|
ffd6ed |
sizeof (xmlXPathObjectPtr), 0, 1);
|
|
|
ffd6ed |
- Xpathobj_val (xpathobjv) = xpathobj;
|
|
|
ffd6ed |
+ Xpathobj_ptr_val (xpathobjv) = xpathobj;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
CAMLreturn (xpathobjv);
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
-v2v_xml_xpathobj_nr_nodes (value xpathobjv)
|
|
|
ffd6ed |
+v2v_xml_xpathobj_ptr_nr_nodes (value xpathobjv)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam1 (xpathobjv);
|
|
|
ffd6ed |
- xmlXPathObjectPtr xpathobj = Xpathobj_val (xpathobjv);
|
|
|
ffd6ed |
+ xmlXPathObjectPtr xpathobj = Xpathobj_ptr_val (xpathobjv);
|
|
|
ffd6ed |
|
|
|
ffd6ed |
if (xpathobj->nodesetval == NULL)
|
|
|
ffd6ed |
CAMLreturn (Val_int (0));
|
|
|
ffd6ed |
@@ -191,10 +194,10 @@ v2v_xml_xpathobj_nr_nodes (value xpathobjv)
|
|
|
ffd6ed |
}
|
|
|
ffd6ed |
|
|
|
ffd6ed |
value
|
|
|
ffd6ed |
-v2v_xml_xpathobj_get_node_ptr (value xpathobjv, value iv)
|
|
|
ffd6ed |
+v2v_xml_xpathobj_ptr_get_node_ptr (value xpathobjv, value iv)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam2 (xpathobjv, iv);
|
|
|
ffd6ed |
- xmlXPathObjectPtr xpathobj = Xpathobj_val (xpathobjv);
|
|
|
ffd6ed |
+ xmlXPathObjectPtr xpathobj = Xpathobj_ptr_val (xpathobjv);
|
|
|
ffd6ed |
int i = Int_val (iv);
|
|
|
ffd6ed |
|
|
|
ffd6ed |
if (i < 0 || i >= xpathobj->nodesetval->nodeNr)
|
|
|
ffd6ed |
@@ -215,7 +218,7 @@ value
|
|
|
ffd6ed |
v2v_xml_xpathctx_set_node_ptr (value xpathctxv, value nodev)
|
|
|
ffd6ed |
{
|
|
|
ffd6ed |
CAMLparam2 (xpathctxv, nodev);
|
|
|
ffd6ed |
- xmlXPathContextPtr xpathctx = Xpathctx_val (xpathctxv);
|
|
|
ffd6ed |
+ xmlXPathContextPtr xpathctx = Xpathctx_ptr_val (xpathctxv);
|
|
|
ffd6ed |
xmlNodePtr node = (xmlNodePtr) nodev;
|
|
|
ffd6ed |
|
|
|
ffd6ed |
xpathctx->node = node;
|
|
|
ffd6ed |
diff --git a/v2v/xml.ml b/v2v/xml.ml
|
|
|
ffd6ed |
index fea8784..16f3f70 100644
|
|
|
ffd6ed |
--- a/v2v/xml.ml
|
|
|
ffd6ed |
+++ b/v2v/xml.ml
|
|
|
ffd6ed |
@@ -18,37 +18,64 @@
|
|
|
ffd6ed |
|
|
|
ffd6ed |
(* Mini interface to libxml2. *)
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-type doc
|
|
|
ffd6ed |
+type doc = doc_ptr
|
|
|
ffd6ed |
+and doc_ptr
|
|
|
ffd6ed |
type node_ptr
|
|
|
ffd6ed |
-type xpathctx
|
|
|
ffd6ed |
-type xpathobj
|
|
|
ffd6ed |
+type xpathctx_ptr
|
|
|
ffd6ed |
+type xpathobj_ptr
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-(* Since node is owned by doc, we have to make that explicit to the
|
|
|
ffd6ed |
- * garbage collector.
|
|
|
ffd6ed |
+(* At the C level, various objects "own" other objects. We have to
|
|
|
ffd6ed |
+ * make that ownership explicit to the garbage collector, else we could
|
|
|
ffd6ed |
+ * end up freeing an object before all the C references to it are
|
|
|
ffd6ed |
+ * freed.
|
|
|
ffd6ed |
*)
|
|
|
ffd6ed |
-type node = doc * node_ptr
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
-external parse_memory : string -> doc = "v2v_xml_parse_memory"
|
|
|
ffd6ed |
-external xpath_new_context : doc -> xpathctx = "v2v_xml_xpath_new_context"
|
|
|
ffd6ed |
-external xpath_eval_expression : xpathctx -> string -> xpathobj = "v2v_xml_xpath_eval_expression"
|
|
|
ffd6ed |
-external xpath_register_ns : xpathctx -> string -> string -> unit = "v2v_xml_xpath_register_ns"
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
-external xpathobj_nr_nodes : xpathobj -> int = "v2v_xml_xpathobj_nr_nodes"
|
|
|
ffd6ed |
-external xpathobj_get_node_ptr : xpathobj -> int -> node_ptr = "v2v_xml_xpathobj_get_node_ptr"
|
|
|
ffd6ed |
-let xpathobj_node doc xpathobj i =
|
|
|
ffd6ed |
- let n = xpathobj_get_node_ptr xpathobj i in
|
|
|
ffd6ed |
- (doc, n)
|
|
|
ffd6ed |
-
|
|
|
ffd6ed |
-external xpathctx_set_node_ptr : xpathctx -> node_ptr -> unit = "v2v_xml_xpathctx_set_node_ptr"
|
|
|
ffd6ed |
-let xpathctx_set_current_context xpathctx (_, node) =
|
|
|
ffd6ed |
- xpathctx_set_node_ptr xpathctx node
|
|
|
ffd6ed |
+type xpathctx = doc_ptr * xpathctx_ptr
|
|
|
ffd6ed |
+type xpathobj = xpathctx * xpathobj_ptr
|
|
|
ffd6ed |
+type node = doc_ptr * node_ptr
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external free_doc_ptr : doc_ptr -> unit = "v2v_xml_free_doc_ptr"
|
|
|
ffd6ed |
+external free_xpathctx_ptr : xpathctx_ptr -> unit = "v2v_xml_free_xpathctx_ptr"
|
|
|
ffd6ed |
+external free_xpathobj_ptr : xpathobj_ptr -> unit = "v2v_xml_free_xpathobj_ptr"
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external _parse_memory : string -> doc_ptr = "v2v_xml_parse_memory"
|
|
|
ffd6ed |
+let parse_memory xml =
|
|
|
ffd6ed |
+ let doc_ptr = _parse_memory xml in
|
|
|
ffd6ed |
+ Gc.finalise free_doc_ptr doc_ptr;
|
|
|
ffd6ed |
+ doc_ptr
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpath_new_context_ptr : doc_ptr -> xpathctx_ptr = "v2v_xml_xpath_new_context_ptr"
|
|
|
ffd6ed |
+let xpath_new_context doc_ptr =
|
|
|
ffd6ed |
+ let xpathctx_ptr = xpath_new_context_ptr doc_ptr in
|
|
|
ffd6ed |
+ Gc.finalise free_xpathctx_ptr xpathctx_ptr;
|
|
|
ffd6ed |
+ doc_ptr, xpathctx_ptr
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpathctx_ptr_register_ns : xpathctx_ptr -> string -> string -> unit = "v2v_xml_xpathctx_ptr_register_ns"
|
|
|
ffd6ed |
+let xpath_register_ns (_, xpathctx_ptr) prefix uri =
|
|
|
ffd6ed |
+ xpathctx_ptr_register_ns xpathctx_ptr prefix uri
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpathctx_ptr_eval_expression : xpathctx_ptr -> string -> xpathobj_ptr = "v2v_xml_xpathctx_ptr_eval_expression"
|
|
|
ffd6ed |
+let xpath_eval_expression ((_, xpathctx_ptr) as xpathctx) expr =
|
|
|
ffd6ed |
+ let xpathobj_ptr = xpathctx_ptr_eval_expression xpathctx_ptr expr in
|
|
|
ffd6ed |
+ Gc.finalise free_xpathobj_ptr xpathobj_ptr;
|
|
|
ffd6ed |
+ xpathctx, xpathobj_ptr
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpathobj_ptr_nr_nodes : xpathobj_ptr -> int = "v2v_xml_xpathobj_ptr_nr_nodes"
|
|
|
ffd6ed |
+let xpathobj_nr_nodes (_, xpathobj_ptr) =
|
|
|
ffd6ed |
+ xpathobj_ptr_nr_nodes xpathobj_ptr
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpathobj_ptr_get_node_ptr : xpathobj_ptr -> int -> node_ptr = "v2v_xml_xpathobj_ptr_get_node_ptr"
|
|
|
ffd6ed |
+let xpathobj_node ((doc_ptr, _), xpathobj_ptr) i =
|
|
|
ffd6ed |
+ doc_ptr, xpathobj_ptr_get_node_ptr xpathobj_ptr i
|
|
|
ffd6ed |
+
|
|
|
ffd6ed |
+external xpathctx_ptr_set_node_ptr : xpathctx_ptr -> node_ptr -> unit = "v2v_xml_xpathctx_set_node_ptr"
|
|
|
ffd6ed |
+let xpathctx_set_current_context (_, xpathctx_ptr) (_, node_ptr) =
|
|
|
ffd6ed |
+ xpathctx_ptr_set_node_ptr xpathctx_ptr node_ptr
|
|
|
ffd6ed |
|
|
|
ffd6ed |
external node_ptr_name : node_ptr -> string = "v2v_xml_node_ptr_name"
|
|
|
ffd6ed |
-let node_name (_, node) = node_ptr_name node
|
|
|
ffd6ed |
+let node_name (_, node_ptr) = node_ptr_name node_ptr
|
|
|
ffd6ed |
|
|
|
ffd6ed |
-external node_ptr_as_string : doc -> node_ptr -> string = "v2v_xml_node_ptr_as_string"
|
|
|
ffd6ed |
-let node_as_string (doc, node) =
|
|
|
ffd6ed |
- node_ptr_as_string doc node
|
|
|
ffd6ed |
+external node_ptr_as_string : doc_ptr -> node_ptr -> string = "v2v_xml_node_ptr_as_string"
|
|
|
ffd6ed |
+let node_as_string (doc_ptr, node_ptr) = node_ptr_as_string doc_ptr node_ptr
|
|
|
ffd6ed |
|
|
|
ffd6ed |
type uri = {
|
|
|
ffd6ed |
uri_scheme : string option;
|
|
|
ffd6ed |
diff --git a/v2v/xml.mli b/v2v/xml.mli
|
|
|
ffd6ed |
index 890fa4e..46c7d3e 100644
|
|
|
ffd6ed |
--- a/v2v/xml.mli
|
|
|
ffd6ed |
+++ b/v2v/xml.mli
|
|
|
ffd6ed |
@@ -34,7 +34,7 @@ val xpath_register_ns : xpathctx -> string -> string -> unit
|
|
|
ffd6ed |
|
|
|
ffd6ed |
val xpathobj_nr_nodes : xpathobj -> int
|
|
|
ffd6ed |
(** Get the number of nodes in the nodeset of the xmlXPathObjectPtr. *)
|
|
|
ffd6ed |
-val xpathobj_node : doc -> xpathobj -> int -> node
|
|
|
ffd6ed |
+val xpathobj_node : xpathobj -> int -> node
|
|
|
ffd6ed |
(** Get the i'th node in the nodeset of the xmlXPathObjectPtr. *)
|
|
|
ffd6ed |
|
|
|
ffd6ed |
val xpathctx_set_current_context : xpathctx -> node -> unit
|
|
|
ffd6ed |
--
|
|
|
ffd6ed |
1.8.3.1
|
|
|
ffd6ed |
|