[Libguestfs] [nbdkit PATCH v2 08/24] ocaml: Implement .cache script callback

[Eric Blake]

This was a bit harder than sh, but still a lot of copy-and-paste.

Signed-off-by: Eric Blake <eblake at redhat.com>

---
Note: I'm not sure how to actually test this beyond compilation.
---
 plugins/ocaml/ocaml.c    | 51 ++++++++++++++++++++++++++++++++++++++++
 plugins/ocaml/NBDKit.ml  | 16 ++++++++++++-
 plugins/ocaml/NBDKit.mli |  5 ++++
 3 files changed, 71 insertions(+), 1 deletion(-)

diff --git a/plugins/ocaml/ocaml.c b/plugins/ocaml/ocaml.c
index 4447d7f..f664a7f 100644
--- a/plugins/ocaml/ocaml.c
+++ b/plugins/ocaml/ocaml.c
@@ -128,6 +128,9 @@ static value can_multi_conn_fn;
 static value can_extents_fn;
 static value extents_fn;

+static value can_cache_fn;
+static value cache_fn;
+
 /*----------------------------------------------------------------------*/
 /* Wrapper functions that translate calls from C (ie. nbdkit) to OCaml. */

@@ -638,6 +641,48 @@ extents_wrapper (void *h, uint32_t count, uint64_t offset, uint32_t flags,
   CAMLreturnT (int, 0);
 }

+static int
+can_cache_wrapper (void *h)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (rv);
+
+  caml_leave_blocking_section ();
+
+  rv = caml_callback_exn (can_cache_fn, *(value *) h);
+  if (Is_exception_result (rv)) {
+    nbdkit_error ("%s", caml_format_exception (Extract_exception (rv)));
+    caml_enter_blocking_section ();
+    CAMLreturnT (int, -1);
+  }
+
+  caml_enter_blocking_section ();
+  CAMLreturnT (int, Int_val (rv));
+}
+
+static int
+cache_wrapper (void *h, uint32_t count, uint64_t offset, uint32_t flags)
+{
+  CAMLparam0 ();
+  CAMLlocal4 (rv, countv, offsetv, flagsv);
+
+  caml_leave_blocking_section ();
+
+  countv = caml_copy_int32 (count);
+  offsetv = caml_copy_int32 (offset);
+  flagsv = Val_flags (flags);
+
+  value args[] = { *(value *) h, countv, offsetv, flagsv };
+  rv = caml_callbackN_exn (cache_fn, sizeof args / sizeof args[0], args);
+  if (Is_exception_result (rv)) {
+    nbdkit_error ("%s", caml_format_exception (Extract_exception (rv)));
+    CAMLreturnT (int, -1);
+  }
+
+  caml_enter_blocking_section ();
+  CAMLreturnT (int, 0);
+}
+
 /*----------------------------------------------------------------------*/
 /* set_* functions called from OCaml code at load time to initialize
  * fields in the plugin struct.
@@ -727,6 +772,9 @@ SET(can_multi_conn)
 SET(can_extents)
 SET(extents)

+SET(can_cache)
+SET(cache)
+
 #undef SET

 static void
@@ -766,6 +814,9 @@ remove_roots (void)
   REMOVE (can_extents);
   REMOVE (extents);

+  REMOVE (can_cache);
+  REMOVE (cache);
+
 #undef REMOVE
 }

diff --git a/plugins/ocaml/NBDKit.ml b/plugins/ocaml/NBDKit.ml
index 7aca8c8..02aa200 100644
--- a/plugins/ocaml/NBDKit.ml
+++ b/plugins/ocaml/NBDKit.ml
@@ -37,6 +37,8 @@ and flag = May_trim | FUA | Req_one

 type fua_flag = FuaNone | FuaEmulate | FuaNative

+type cache_flag = CacheNone | CacheEmulate | CacheNop
+
 type extent = {
   offset : int64;
   length : int64;
@@ -82,6 +84,9 @@ type 'a plugin = {

   can_extents : ('a -> bool) option;
   extents : ('a -> int32 -> int64 -> flags -> extent list) option;
+
+  can_cache : ('a -> cache_flag) option;
+  cache : ('a -> int32 -> int64 -> flags -> unit) option;
 }

 let default_callbacks = {
@@ -122,6 +127,9 @@ let default_callbacks = {

   can_extents = None;
   extents = None;
+
+  can_cache = None;
+  cache = None;
 }

 type thread_model =
@@ -170,6 +178,9 @@ external set_can_multi_conn : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_multi
 external set_can_extents : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_extents"
 external set_extents : ('a -> int32 -> int64 -> flags -> extent list) -> unit = "ocaml_nbdkit_set_extents"

+external set_can_cache : ('a -> cache_flag) -> unit = "ocaml_nbdkit_set_can_cache"
+external set_cache : ('a -> int32 -> int64 -> flags -> unit) -> unit = "ocaml_nbdkit_set_cache"
+
 let may f = function None -> () | Some a -> f a

 let register_plugin thread_model plugin =
@@ -229,7 +240,10 @@ let register_plugin thread_model plugin =
   may set_can_multi_conn plugin.can_multi_conn;

   may set_can_extents plugin.can_extents;
-  may set_extents plugin.extents
+  may set_extents plugin.extents;
+
+  may set_can_cache plugin.can_cache;
+  may set_cache plugin.cache

 external _set_error : int -> unit = "ocaml_nbdkit_set_error" "noalloc"

diff --git a/plugins/ocaml/NBDKit.mli b/plugins/ocaml/NBDKit.mli
index da110fe..bab8f7f 100644
--- a/plugins/ocaml/NBDKit.mli
+++ b/plugins/ocaml/NBDKit.mli
@@ -40,6 +40,8 @@ and flag = May_trim | FUA | Req_one

 type fua_flag = FuaNone | FuaEmulate | FuaNative

+type cache_flag = CacheNone | CacheEmulate | CacheNop
+
 type extent = {
   offset : int64;
   length : int64;
@@ -86,6 +88,9 @@ type 'a plugin = {

   can_extents : ('a -> bool) option;
   extents : ('a -> int32 -> int64 -> flags -> extent list) option;
+
+  can_cache : ('a -> cache_flag) option;
+  cache : ('a -> int32 -> int64 -> flags -> unit) option;
 }
 (** The plugin fields and callbacks.  ['a] is the handle type. *)

-- 
2.20.1