2 * Copyright (C) 2009-2011 Red Hat Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
26 #include <caml/config.h>
27 #include <caml/alloc.h>
28 #include <caml/callback.h>
29 #include <caml/custom.h>
30 #include <caml/fail.h>
31 #include <caml/memory.h>
32 #include <caml/mlvalues.h>
33 #include <caml/printexc.h>
34 #include <caml/signals.h>
36 #include "guestfs_c.h"
38 static value **get_all_event_callbacks (guestfs_h *g, size_t *len_rtn);
39 static void event_callback_wrapper (guestfs_h *g, void *data, uint64_t event, int event_handle, int flags, const char *buf, size_t buf_len, const uint64_t *array, size_t array_len);
41 /* This macro was added in OCaml 3.10. Backport for earlier versions. */
43 #define CAMLreturnT(type, result) do{ \
44 type caml__temp_result = (result); \
45 caml_local_roots = caml__frame; \
46 return (caml__temp_result); \
50 /* These prototypes are solely to quiet gcc warning. */
51 CAMLprim value ocaml_guestfs_create (void);
52 CAMLprim value ocaml_guestfs_close (value gv);
53 CAMLprim value ocaml_guestfs_set_event_callback (value gv, value closure, value events);
54 CAMLprim value ocaml_guestfs_delete_event_callback (value gv, value eh);
56 /* Allocate handles and deal with finalization. */
58 guestfs_finalize (value gv)
60 guestfs_h *g = Guestfs_val (gv);
63 /* There is a nasty, difficult to solve case here where the
64 * user deletes events in one of the callbacks that we are
65 * about to invoke, resulting in a double-free. XXX
68 value **roots = get_all_event_callbacks (g, &len);
70 value *v = guestfs_get_private (g, "_ocaml_g");
72 /* Close the handle: this could invoke callbacks from the list
73 * above, which is why we don't want to delete them before
78 /* Now unregister the global roots. */
79 for (i = 0; i < len; ++i) {
80 caml_remove_global_root (roots[i]);
84 caml_remove_global_root (v);
89 static struct custom_operations guestfs_custom_operations = {
90 (char *) "guestfs_custom_operations",
92 custom_compare_default,
94 custom_serialize_default,
95 custom_deserialize_default
99 Val_guestfs (guestfs_h *g)
104 rv = caml_alloc_custom (&guestfs_custom_operations,
105 sizeof (guestfs_h *), 0, 1);
106 Guestfs_val (rv) = g;
112 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
118 msg = guestfs_last_error (g);
121 v = caml_copy_string (msg);
123 v = caml_copy_string (func);
124 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
129 ocaml_guestfs_raise_closed (const char *func)
134 v = caml_copy_string (func);
135 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
141 ocaml_guestfs_create (void)
148 g = guestfs_create ();
150 caml_failwith ("failed to create guestfs handle");
152 guestfs_set_error_handler (g, NULL, NULL);
154 gv = Val_guestfs (g);
156 /* Store the OCaml handle into the C handle. This is only so we can
157 * map the C handle to the OCaml handle in event_callback_wrapper.
159 v = guestfs_safe_malloc (g, sizeof *v);
161 /* XXX This global root is generational, but we cannot rely on every
162 * user having the OCaml 3.11 version which supports this.
164 caml_register_global_root (v);
165 guestfs_set_private (g, "_ocaml_g", v);
172 ocaml_guestfs_close (value gv)
176 guestfs_finalize (gv);
178 /* So we don't double-free in the finalizer. */
179 Guestfs_val (gv) = NULL;
181 CAMLreturn (Val_unit);
184 /* Copy string array value. */
186 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
192 r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
193 for (i = 0; i < Wosize_val (sv); ++i)
194 r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
197 CAMLreturnT (char **, r);
200 /* Free array of strings. */
202 ocaml_guestfs_free_strings (char **argv)
206 for (i = 0; argv[i] != NULL; ++i)
212 event_bitmask_of_event_list (value events)
216 while (events != Val_int (0)) {
217 r |= UINT64_C(1) << Int_val (Field (events, 0));
218 events = Field (events, 1);
224 /* Guestfs.set_event_callback */
226 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
228 CAMLparam3 (gv, closure, events);
231 uint64_t event_bitmask;
233 guestfs_h *g = Guestfs_val (gv);
235 event_bitmask = event_bitmask_of_event_list (events);
237 value *root = guestfs_safe_malloc (g, sizeof *root);
240 eh = guestfs_set_event_callback (g, event_callback_wrapper,
241 event_bitmask, 0, root);
245 ocaml_guestfs_raise_error (g, "set_event_callback");
248 /* XXX This global root is generational, but we cannot rely on every
249 * user having the OCaml 3.11 version which supports this.
251 caml_register_global_root (root);
253 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
254 guestfs_set_private (g, key, root);
256 CAMLreturn (Val_int (eh));
259 /* Guestfs.delete_event_callback */
261 ocaml_guestfs_delete_event_callback (value gv, value ehv)
263 CAMLparam2 (gv, ehv);
265 int eh = Int_val (ehv);
267 guestfs_h *g = Guestfs_val (gv);
269 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
271 value *root = guestfs_get_private (g, key);
273 caml_remove_global_root (root);
275 guestfs_set_private (g, key, NULL);
276 guestfs_delete_event_callback (g, eh);
279 CAMLreturn (Val_unit);
283 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
290 /* Count the length of the array that will be needed. */
292 root = guestfs_first_private (g, &key);
293 while (root != NULL) {
294 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
296 root = guestfs_next_private (g, &key);
299 /* Copy them into the return array. */
300 r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
303 root = guestfs_first_private (g, &key);
304 while (root != NULL) {
305 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
309 root = guestfs_next_private (g, &key);
315 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
317 event_bitmask_to_event (uint64_t event)
328 event_callback_wrapper (guestfs_h *g,
333 const char *buf, size_t buf_len,
334 const uint64_t *array, size_t array_len)
337 CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
342 root = guestfs_get_private (g, "_ocaml_g");
345 /* Only one bit should be set in 'event'. Which one? */
346 evv = Val_int (event_bitmask_to_event (event));
348 ehv = Val_int (event_handle);
350 bufv = caml_alloc_string (buf_len);
351 memcpy (String_val (bufv), buf, buf_len);
353 arrayv = caml_alloc (array_len, 0);
354 for (i = 0; i < array_len; ++i) {
355 v = caml_copy_int64 (array[i]);
356 Store_field (arrayv, i, v);
359 value args[5] = { gv, evv, ehv, bufv, arrayv };
361 caml_leave_blocking_section ();
362 rv = caml_callbackN_exn (*(value*)data, 5, args);
363 caml_enter_blocking_section ();
365 /* Callbacks shouldn't throw exceptions. There's not much we can do
366 * except to print it.
368 if (Is_exception_result (rv))
370 "libguestfs: uncaught OCaml exception in event callback: %s",
371 caml_format_exception (Extract_exception (rv)));