10:39 a.m.
---
.gitignore | 1 +
daemon/Makefile.am | 1 +
generator/OCaml.ml | 8 ++++
generator/OCaml.mli | 1 +
generator/daemon.ml | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++-
generator/main.ml | 2 +
6 files changed, 127 insertions(+), 2 deletions(-)
diff --git a/.gitignore b/.gitignore
index 29596594a..8aea2cdb4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -180,6 +180,7 @@ Makefile.in
/daemon/stamp-guestfsd.pod
/daemon/structs-cleanups.c
/daemon/structs-cleanups.h
+/daemon/structs.ml
/daemon/stubs-?.c
/daemon/stubs.h
/daemon/types.ml
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 6ff71bb1f..4a818a7a9 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -275,6 +275,7 @@ SOURCES_MLI = \
SOURCES_ML = \
types.ml \
utils.ml \
+ structs.ml \
sysroot.ml \
mountable.ml \
chroot.ml \
diff --git a/generator/OCaml.ml b/generator/OCaml.ml
index 53f105198..853b41bb3 100644
--- a/generator/OCaml.ml
+++ b/generator/OCaml.ml
@@ -888,3 +888,11 @@ and generate_ocaml_function_type ?(extra_unit = false) (ret, args,
optargs) =
| RStructList (_, typ) -> pr "%s array" typ
| RHashtable _ -> pr "(string * string) list"
)
+
+(* Structure definitions (again). These are used in the daemon,
+ * but it's convenient to generate them here.
+ *)
+and generate_ocaml_daemon_structs () =
+ generate_header OCamlStyle GPLv2plus;
+
+ generate_ocaml_structure_decls ()
diff --git a/generator/OCaml.mli b/generator/OCaml.mli
index 4e79a5b5a..a36fbe02f 100644
--- a/generator/OCaml.mli
+++ b/generator/OCaml.mli
@@ -20,3 +20,4 @@ val generate_ocaml_c : unit -> unit
val generate_ocaml_c_errnos : unit -> unit
val generate_ocaml_ml : unit -> unit
val generate_ocaml_mli : unit -> unit
+val generate_ocaml_daemon_structs : unit -> unit
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 1d7461f8c..8cac5ccb1 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -575,6 +575,110 @@ return_string_list (value retv)
";
+ (* Implement code for returning structs and struct lists. *)
+ let emit_return_struct typ =
+ let struc = Structs.lookup_struct typ in
+ pr "/* Implement RStruct (%S, _). */\n" typ;
+ pr "static guestfs_int_%s *\n" typ;
+ pr "return_%s (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s *ret;\n" typ;
+ pr " value v;\n";
+ pr "\n";
+ pr " ret = malloc (sizeof (*ret));\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ iteri (
+ fun i ->
+ pr " v = Field (retv, %d);\n" i;
+ function
+ | n, (FString|FUUID) ->
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, FBuffer ->
+ pr " ret->%s_len = caml_string_length (v);\n" n;
+ pr " ret->%s = strdup (String_val (v));\n" n;
+ pr " if (ret->%s == NULL) return NULL;\n" n
+ | n, (FBytes|FInt64|FUInt64) ->
+ pr " ret->%s = Int64_val (v);\n" n
+ | n, (FInt32|FUInt32) ->
+ pr " ret->%s = Int32_val (v);\n" n
+ | n, FOptPercent ->
+ pr " if (v == Val_int (0)) /* None */\n";
+ pr " ret->%s = -1;\n" n;
+ pr " else {\n";
+ pr " v = Field (v, 0);\n";
+ pr " ret->%s = Double_val (v);\n" n;
+ pr " }\n"
+ | n, FChar ->
+ pr " ret->%s = Int_val (v);\n" n
+ ) struc.s_cols;
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n"
+
+ and emit_return_struct_list typ =
+ pr "/* Implement RStructList (%S, _). */\n" typ;
+ pr "static guestfs_int_%s_list *\n" typ;
+ pr "return_%s_list (value retv)\n" typ;
+ pr "{\n";
+ pr " guestfs_int_%s_list *ret;\n" typ;
+ pr " guestfs_int_%s *r;\n" typ;
+ pr " size_t i, len;\n";
+ pr " value v, rv;\n";
+ pr "\n";
+ pr " /* Count the number of elements in the list. */\n";
+ pr " rv = retv;\n";
+ pr " len = 0;\n";
+ pr " while (rv != Val_int (0)) {\n";
+ pr " len++;\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " ret = malloc (sizeof *ret);\n";
+ pr " if (ret == NULL) {\n";
+ pr " reply_with_perror (\"malloc\");\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr " ret->guestfs_int_%s_list_len = len;\n" typ;
+ pr " ret->guestfs_int_%s_list_val =\n" typ;
+ pr " calloc (len, sizeof (guestfs_int_%s));\n" typ;
+ pr " if (ret->guestfs_int_%s_list_val == NULL) {\n" typ;
+ pr " reply_with_perror (\"calloc\");\n";
+ pr " free (ret);\n";
+ pr " return NULL;\n";
+ pr " }\n";
+ pr "\n";
+ pr " rv = retv;\n";
+ pr " for (i = 0; i < len; ++i) {\n";
+ pr " v = Field (rv, 0);\n";
+ pr " r = return_%s (v);\n" typ;
+ pr " if (r == NULL)\n";
+ pr " return NULL; /* XXX leaks memory along this error path */\n";
+ pr " memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof
(*r));\n" typ;
+ pr " free (r);\n";
+ pr " rv = Field (rv, 1);\n";
+ pr " }\n";
+ pr "\n";
+ pr " return ret;\n";
+ pr "}\n";
+ pr "\n";
+ in
+
+ List.iter (
+ function
+ | typ, RStructOnly ->
+ emit_return_struct typ
+ | typ, (RStructListOnly | RStructAndList) ->
+ emit_return_struct typ;
+ emit_return_struct_list typ
+ ) (rstructs_used_by (actions |> impl_ocaml_functions));
+
+ (* Implement the wrapper functions. *)
List.iter (
fun ({ name = name; style = ret, args, optargs } as f) ->
let uc_name = String.uppercase_ascii name in
@@ -709,8 +813,16 @@ return_string_list (value retv)
| RStringList _ ->
pr " char **ret = return_string_list (retv);\n";
pr " CAMLreturnT (char **, ret); /* caller frees */\n"
- | RStruct _ -> assert false
- | RStructList _ -> assert false
+ | RStruct (_, typ) ->
+ pr " guestfs_int_%s *ret =\n" typ;
+ pr " return_%s (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s *, ret);\n" typ
+ | RStructList (_, typ) ->
+ pr " guestfs_int_%s_list *ret =\n" typ;
+ pr " return_%s_list (retv);\n" typ;
+ pr " /* caller frees */\n";
+ pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ
| RHashtable _ -> assert false
| RBufferOut _ -> assert false
);
diff --git a/generator/main.ml b/generator/main.ml
index a6c805e2e..72f704b8e 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -191,6 +191,8 @@ Run it from the top source directory using the command
OCaml.generate_ocaml_c;
output_to "ocaml/guestfs-c-errnos.c"
OCaml.generate_ocaml_c_errnos;
+ output_to "daemon/structs.ml"
+ OCaml.generate_ocaml_daemon_structs;
output_to "ocaml/bindtests.ml"
Bindtests.generate_ocaml_bindtests;
--
2.13.0