12:47 p.m.
Somewhat of a mishmash between .open (in that it takes a bool readonly
parameter) and .config_complete (in that the C code returns an int,
but the Ocaml code either throws an exception or completes with unit).
I did not spot any existing testsuite coverage to modify for this, and
am relying on the fact that it compiles cleanly.
Signed-off-by: Eric Blake <eblake(a)redhat.com>
---
plugins/ocaml/NBDKit.ml | 12 ++++++++++--
plugins/ocaml/NBDKit.mli | 4 +++-
plugins/ocaml/ocaml.c | 27 ++++++++++++++++++++++++++-
3 files changed, 39 insertions(+), 4 deletions(-)
diff --git a/plugins/ocaml/NBDKit.ml b/plugins/ocaml/NBDKit.ml
index 7002ac0..85c30a1 100644
--- a/plugins/ocaml/NBDKit.ml
+++ b/plugins/ocaml/NBDKit.ml
@@ -1,6 +1,6 @@
(* hey emacs, this is OCaml code: -*- tuareg -*- *)
(* nbdkit OCaml interface
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
@@ -98,6 +98,8 @@ type 'a plugin = {
thread_model : (unit -> thread_model) option;
can_fast_zero : ('a -> bool) option;
+
+ preconnect : (bool -> unit) option;
}
let default_callbacks = {
@@ -145,6 +147,8 @@ let default_callbacks = {
thread_model = None;
can_fast_zero = None;
+
+ preconnect = None;
}
external set_name : string -> unit = "ocaml_nbdkit_set_name"
"noalloc"
@@ -192,6 +196,8 @@ external set_thread_model : (unit -> thread_model) -> unit =
"ocaml_nbdkit_set_t
external set_can_fast_zero : ('a -> bool) -> unit =
"ocaml_nbdkit_set_can_fast_zero"
+external set_preconnect : (bool -> unit) -> unit =
"ocaml_nbdkit_set_preconnect"
+
let may f = function None -> () | Some a -> f a
let register_plugin plugin =
@@ -257,7 +263,9 @@ let register_plugin plugin =
may set_thread_model plugin.thread_model;
- may set_can_fast_zero plugin.can_fast_zero
+ may set_can_fast_zero plugin.can_fast_zero;
+
+ may set_preconnect plugin.preconnect
external _set_error : int -> unit = "ocaml_nbdkit_set_error"
"noalloc"
diff --git a/plugins/ocaml/NBDKit.mli b/plugins/ocaml/NBDKit.mli
index 06648b7..4cdf911 100644
--- a/plugins/ocaml/NBDKit.mli
+++ b/plugins/ocaml/NBDKit.mli
@@ -1,6 +1,6 @@
(* hey emacs, this is OCaml code: -*- tuareg -*- *)
(* nbdkit OCaml interface
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
@@ -103,6 +103,8 @@ type 'a plugin = {
thread_model : (unit -> thread_model) option;
can_fast_zero : ('a -> bool) option;
+
+ preconnect : (bool -> unit) option;
}
(** The plugin fields and callbacks. ['a] is the handle type. *)
diff --git a/plugins/ocaml/ocaml.c b/plugins/ocaml/ocaml.c
index cb69290..a7d188f 100644
--- a/plugins/ocaml/ocaml.c
+++ b/plugins/ocaml/ocaml.c
@@ -1,5 +1,5 @@
/* nbdkit
- * Copyright (C) 2014-2019 Red Hat Inc.
+ * Copyright (C) 2014-2020 Red Hat Inc.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
@@ -136,6 +136,8 @@ static value thread_model_fn;
static value can_fast_zero_fn;
+static value preconnect_fn;
+
/*----------------------------------------------------------------------*/
/* Wrapper functions that translate calls from C (ie. nbdkit) to OCaml. */
@@ -726,6 +728,25 @@ can_fast_zero_wrapper (void *h)
CAMLreturnT (int, Bool_val (rv));
}
+static int
+preconnect_wrapper (int readonly)
+{
+ CAMLparam0 ();
+ CAMLlocal1 (rv);
+
+ caml_leave_blocking_section ();
+
+ rv = caml_callback_exn (preconnect_fn, Val_bool (readonly));
+ 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, 1);
+}
+
/*----------------------------------------------------------------------*/
/* set_* functions called from OCaml code at load time to initialize
* fields in the plugin struct.
@@ -815,6 +836,8 @@ SET(thread_model)
SET(can_fast_zero)
+SET(preconnect)
+
#undef SET
static void
@@ -861,6 +884,8 @@ remove_roots (void)
REMOVE (can_fast_zero);
+ REMOVE (preconnect);
+
#undef REMOVE
}
--
2.24.1