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]);
87 caml_remove_global_root (v);
92 static struct custom_operations guestfs_custom_operations = {
93 (char *) "guestfs_custom_operations",
95 custom_compare_default,
97 custom_serialize_default,
98 custom_deserialize_default
102 Val_guestfs (guestfs_h *g)
107 rv = caml_alloc_custom (&guestfs_custom_operations,
108 sizeof (guestfs_h *), 0, 1);
109 Guestfs_val (rv) = g;
115 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
121 msg = guestfs_last_error (g);
124 v = caml_copy_string (msg);
126 v = caml_copy_string (func);
127 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
132 ocaml_guestfs_raise_closed (const char *func)
137 v = caml_copy_string (func);
138 caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
144 ocaml_guestfs_create (void)
151 g = guestfs_create ();
153 caml_failwith ("failed to create guestfs handle");
155 guestfs_set_error_handler (g, NULL, NULL);
157 gv = Val_guestfs (g);
159 /* Store the OCaml handle into the C handle. This is only so we can
160 * map the C handle to the OCaml handle in event_callback_wrapper.
162 v = guestfs_safe_malloc (g, sizeof *v);
164 /* XXX This global root is generational, but we cannot rely on every
165 * user having the OCaml 3.11 version which supports this.
167 caml_register_global_root (v);
168 guestfs_set_private (g, "_ocaml_g", v);
175 ocaml_guestfs_close (value gv)
179 guestfs_finalize (gv);
181 /* So we don't double-free in the finalizer. */
182 Guestfs_val (gv) = NULL;
184 CAMLreturn (Val_unit);
187 /* Copy string array value. */
189 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
195 r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
196 for (i = 0; i < Wosize_val (sv); ++i)
197 r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
200 CAMLreturnT (char **, r);
203 /* Free array of strings. */
205 ocaml_guestfs_free_strings (char **argv)
209 for (i = 0; argv[i] != NULL; ++i)
215 event_bitmask_of_event_list (value events)
219 while (events != Val_int (0)) {
220 r |= UINT64_C(1) << Int_val (Field (events, 0));
221 events = Field (events, 1);
227 /* Guestfs.set_event_callback */
229 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
231 CAMLparam3 (gv, closure, events);
234 uint64_t event_bitmask;
236 guestfs_h *g = Guestfs_val (gv);
238 event_bitmask = event_bitmask_of_event_list (events);
240 value *root = guestfs_safe_malloc (g, sizeof *root);
243 eh = guestfs_set_event_callback (g, event_callback_wrapper,
244 event_bitmask, 0, root);
248 ocaml_guestfs_raise_error (g, "set_event_callback");
251 /* XXX This global root is generational, but we cannot rely on every
252 * user having the OCaml 3.11 version which supports this.
254 caml_register_global_root (root);
256 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
257 guestfs_set_private (g, key, root);
259 CAMLreturn (Val_int (eh));
262 /* Guestfs.delete_event_callback */
264 ocaml_guestfs_delete_event_callback (value gv, value ehv)
266 CAMLparam2 (gv, ehv);
268 int eh = Int_val (ehv);
270 guestfs_h *g = Guestfs_val (gv);
272 snprintf (key, sizeof key, "_ocaml_event_%d", eh);
274 value *root = guestfs_get_private (g, key);
276 caml_remove_global_root (root);
278 guestfs_set_private (g, key, NULL);
279 guestfs_delete_event_callback (g, eh);
282 CAMLreturn (Val_unit);
286 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
293 /* Count the length of the array that will be needed. */
295 root = guestfs_first_private (g, &key);
296 while (root != NULL) {
297 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
299 root = guestfs_next_private (g, &key);
302 /* Copy them into the return array. */
303 r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
306 root = guestfs_first_private (g, &key);
307 while (root != NULL) {
308 if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
312 root = guestfs_next_private (g, &key);
318 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
320 event_bitmask_to_event (uint64_t event)
331 event_callback_wrapper_locked (guestfs_h *g,
336 const char *buf, size_t buf_len,
337 const uint64_t *array, size_t array_len)
340 CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
345 root = guestfs_get_private (g, "_ocaml_g");
348 /* Only one bit should be set in 'event'. Which one? */
349 evv = Val_int (event_bitmask_to_event (event));
351 ehv = Val_int (event_handle);
353 bufv = caml_alloc_string (buf_len);
354 memcpy (String_val (bufv), buf, buf_len);
356 arrayv = caml_alloc (array_len, 0);
357 for (i = 0; i < array_len; ++i) {
358 v = caml_copy_int64 (array[i]);
359 Store_field (arrayv, i, v);
362 value args[5] = { gv, evv, ehv, bufv, arrayv };
364 rv = caml_callbackN_exn (*(value*)data, 5, args);
366 /* Callbacks shouldn't throw exceptions. There's not much we can do
367 * except to print it.
369 if (Is_exception_result (rv))
371 "libguestfs: uncaught OCaml exception in event callback: %s",
372 caml_format_exception (Extract_exception (rv)));
378 event_callback_wrapper (guestfs_h *g,
383 const char *buf, size_t buf_len,
384 const uint64_t *array, size_t array_len)
386 /* Ensure we are holding the GC lock before any GC operations are
387 * possible. (RHBZ#725824)
389 caml_leave_blocking_section ();
391 event_callback_wrapper_locked (g, data, event, event_handle, flags,
392 buf, buf_len, array, array_len);
394 caml_enter_blocking_section ();
398 ocaml_guestfs_last_errno (value gv)
405 g = Guestfs_val (gv);
407 ocaml_guestfs_raise_closed ("last_errno");
409 r = guestfs_last_errno (g);
415 /* NB: This is and must remain a "noalloc" function. */
417 ocaml_guestfs_user_cancel (value gv)
419 guestfs_h *g = Guestfs_val (gv);
421 guestfs_user_cancel (g);