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);
55 value ocaml_guestfs_last_errno (value gv);
56 value ocaml_guestfs_user_cancel (value gv);
58 /* Allocate handles and deal with finalization. */
60 guestfs_finalize (value gv)
62 guestfs_h *g = Guestfs_val (gv);
65 /* There is a nasty, difficult to solve case here where the
66 * user deletes events in one of the callbacks that we are
67 * about to invoke, resulting in a double-free. XXX
70 value **roots = get_all_event_callbacks (g, &len);
72 value *v = guestfs_get_private (g, "_ocaml_g");
74 /* Close the handle: this could invoke callbacks from the list
75 * above, which is why we don't want to delete them before
80 /* Now unregister the global roots. */
81 for (i = 0; i < len; ++i) {
82 caml_remove_global_root (roots[i]);
86 caml_remove_global_root (v);
91 static struct custom_operations guestfs_custom_operations = {
92 (char *) "guestfs_custom_operations",
94 custom_compare_default,
96 custom_serialize_default,
97 custom_deserialize_default
101 Val_guestfs (guestfs_h *g)
106 rv = caml_alloc_custom (&guestfs_custom_operations,
107 sizeof (guestfs_h *), 0, 1);
108 Guestfs_val (rv) = g;
114 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
120 msg = guestfs_last_error (g);
123 v = caml_copy_string (msg);
125 v = caml_copy_string (func);
126 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
131 ocaml_guestfs_raise_closed (const char *func)
136 v = caml_copy_string (func);
137 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
143 ocaml_guestfs_create (void)
150 g = guestfs_create ();
152 caml_failwith ("failed to create guestfs handle");
154 guestfs_set_error_handler (g, NULL, NULL);
156 gv = Val_guestfs (g);
158 /* Store the OCaml handle into the C handle. This is only so we can
159 * map the C handle to the OCaml handle in event_callback_wrapper.
161 v = guestfs_safe_malloc (g, sizeof *v);
163 /* XXX This global root is generational, but we cannot rely on every
164 * user having the OCaml 3.11 version which supports this.
166 caml_register_global_root (v);
167 guestfs_set_private (g, "_ocaml_g", v);
174 ocaml_guestfs_close (value gv)
178 guestfs_finalize (gv);
180 /* So we don't double-free in the finalizer. */
181 Guestfs_val (gv) = NULL;
183 CAMLreturn (Val_unit);
186 /* Copy string array value. */
188 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
194 r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
195 for (i = 0; i < Wosize_val (sv); ++i)
196 r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
199 CAMLreturnT (char **, r);
202 /* Free array of strings. */
204 ocaml_guestfs_free_strings (char **argv)
208 for (i = 0; argv[i] != NULL; ++i)
214 event_bitmask_of_event_list (value events)
218 while (events != Val_int (0)) {
219 r |= UINT64_C(1) << Int_val (Field (events, 0));
220 events = Field (events, 1);
226 /* Guestfs.set_event_callback */
228 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
230 CAMLparam3 (gv, closure, events);
233 uint64_t event_bitmask;
235 guestfs_h *g = Guestfs_val (gv);
237 event_bitmask = event_bitmask_of_event_list (events);
239 value *root = guestfs_safe_malloc (g, sizeof *root);
242 eh = guestfs_set_event_callback (g, event_callback_wrapper,
243 event_bitmask, 0, root);
247 ocaml_guestfs_raise_error (g, "set_event_callback");
250 /* XXX This global root is generational, but we cannot rely on every
251 * user having the OCaml 3.11 version which supports this.
253 caml_register_global_root (root);
255 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
256 guestfs_set_private (g, key, root);
258 CAMLreturn (Val_int (eh));
261 /* Guestfs.delete_event_callback */
263 ocaml_guestfs_delete_event_callback (value gv, value ehv)
265 CAMLparam2 (gv, ehv);
267 int eh = Int_val (ehv);
269 guestfs_h *g = Guestfs_val (gv);
271 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
273 value *root = guestfs_get_private (g, key);
275 caml_remove_global_root (root);
277 guestfs_set_private (g, key, NULL);
278 guestfs_delete_event_callback (g, eh);
281 CAMLreturn (Val_unit);
285 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
292 /* Count the length of the array that will be needed. */
294 root = guestfs_first_private (g, &key);
295 while (root != NULL) {
296 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
298 root = guestfs_next_private (g, &key);
301 /* Copy them into the return array. */
302 r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
305 root = guestfs_first_private (g, &key);
306 while (root != NULL) {
307 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
311 root = guestfs_next_private (g, &key);
317 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
319 event_bitmask_to_event (uint64_t event)
330 event_callback_wrapper_locked (guestfs_h *g,
335 const char *buf, size_t buf_len,
336 const uint64_t *array, size_t array_len)
339 CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
344 root = guestfs_get_private (g, "_ocaml_g");
347 /* Only one bit should be set in 'event'. Which one? */
348 evv = Val_int (event_bitmask_to_event (event));
350 ehv = Val_int (event_handle);
352 bufv = caml_alloc_string (buf_len);
353 memcpy (String_val (bufv), buf, buf_len);
355 arrayv = caml_alloc (array_len, 0);
356 for (i = 0; i < array_len; ++i) {
357 v = caml_copy_int64 (array[i]);
358 Store_field (arrayv, i, v);
361 value args[5] = { gv, evv, ehv, bufv, arrayv };
363 rv = caml_callbackN_exn (*(value*)data, 5, args);
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)));
377 event_callback_wrapper (guestfs_h *g,
382 const char *buf, size_t buf_len,
383 const uint64_t *array, size_t array_len)
385 /* Ensure we are holding the GC lock before any GC operations are
386 * possible. (RHBZ#725824)
388 caml_leave_blocking_section ();
390 event_callback_wrapper_locked (g, data, event, event_handle, flags,
391 buf, buf_len, array, array_len);
393 caml_enter_blocking_section ();
397 ocaml_guestfs_last_errno (value gv)
404 g = Guestfs_val (gv);
406 ocaml_guestfs_raise_closed ("last_errno");
408 r = guestfs_last_errno (g);
414 /* NB: This is and must remain a "noalloc" function. */
416 ocaml_guestfs_user_cancel (value gv)
418 guestfs_h *g = Guestfs_val (gv);
420 guestfs_user_cancel (g);