diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | generator/.depend | 6 | ||||
| -rw-r--r-- | generator/generator_ocaml.ml | 84 | ||||
| -rw-r--r-- | ocaml/Makefile.am | 6 | ||||
| -rw-r--r-- | ocaml/guestfs_c.c | 195 | ||||
| -rw-r--r-- | ocaml/guestfs_c.h | 2 | ||||
| -rw-r--r-- | ocaml/t/guestfs_400_events.ml | 71 | ||||
| -rw-r--r-- | ocaml/t/guestfs_400_progress.ml | 10 |
8 files changed, 305 insertions, 70 deletions
@@ -211,6 +211,7 @@ ocaml/t/guestfs_005_load ocaml/t/guestfs_010_basic ocaml/t/guestfs_070_threads ocaml/t/guestfs_080_optargs +ocaml/t/guestfs_400_events ocaml/t/guestfs_400_progress perl/bindtests.pl perl/blib diff --git a/generator/.depend b/generator/.depend index d96d4f39..201b3a22 100644 --- a/generator/.depend +++ b/generator/.depend @@ -68,10 +68,12 @@ generator_fish.cmx: generator_utils.cmx generator_types.cmx \ generator_actions.cmx generator_ocaml.cmo: generator_utils.cmi generator_types.cmo \ generator_structs.cmi generator_pr.cmi generator_optgroups.cmo \ - generator_docstrings.cmo generator_c.cmo generator_actions.cmi + generator_events.cmo generator_docstrings.cmo generator_c.cmo \ + generator_actions.cmi generator_ocaml.cmx: generator_utils.cmx generator_types.cmx \ generator_structs.cmx generator_pr.cmx generator_optgroups.cmx \ - generator_docstrings.cmx generator_c.cmx generator_actions.cmx + generator_events.cmx generator_docstrings.cmx generator_c.cmx \ + generator_actions.cmx generator_perl.cmo: generator_utils.cmi generator_types.cmo \ generator_structs.cmi generator_pr.cmi generator_optgroups.cmo \ generator_docstrings.cmo generator_c.cmo generator_actions.cmi diff --git a/generator/generator_ocaml.ml b/generator/generator_ocaml.ml index ced6fb42..aa1adec4 100644 --- a/generator/generator_ocaml.ml +++ b/generator/generator_ocaml.ml @@ -1,5 +1,5 @@ (* libguestfs - * Copyright (C) 2009-2010 Red Hat Inc. + * Copyright (C) 2009-2011 Red Hat Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -28,6 +28,7 @@ open Generator_optgroups open Generator_actions open Generator_structs open Generator_c +open Generator_events (* Generate the OCaml bindings interface. *) let rec generate_ocaml_mli () = @@ -60,27 +61,38 @@ val close : t -> unit unreferenced, but callers can call this in order to provide predictable cleanup. *) -type progress_cb = int -> int -> int64 -> int64 -> unit +type event = +"; + List.iter ( + fun (name, _) -> + pr " | EVENT_%s\n" (String.uppercase name) + ) events; + pr "\n"; + + pr "\ +val event_all : event list +(** A list containing all event types. *) -val set_progress_callback : t -> progress_cb -> unit -(** [set_progress_callback g f] sets [f] as the progress callback function. - For some long-running functions, [f] will be called repeatedly - during the function with progress updates. +type event_handle +(** The opaque event handle which can be used to delete event callbacks. *) - The callback is [f proc_nr serial position total]. See - the description of [guestfs_set_progress_callback] in guestfs(3) - for the meaning of these four numbers. +type event_callback = + t -> event -> event_handle -> string -> int64 array -> unit +(** The event callback. *) + +val set_event_callback : t -> event_callback -> event list -> event_handle +(** [set_event_callback g f es] sets [f] as the event callback function + for all events in the set [es]. Note that if the closure captures a reference to the handle, this reference will prevent the handle from being - automatically closed by the garbage collector. There are - three ways to avoid this: be careful not to capture the handle - in the closure, or use a weak reference, or call - {!Guestfs.clear_progress_callback} to remove the reference. *) + automatically closed by the garbage collector. Since the + handle is passed to the event callback, with careful programming + it should be possible to avoid capturing the handle in the closure. *) -val clear_progress_callback : t -> unit -(** [clear_progress_callback g] removes any progress callback function - associated with the handle. See {!Guestfs.set_progress_callback}. *) +val delete_event_callback : t -> event_handle -> unit +(** [delete_event_callback g eh] removes a previously registered + event callback. See {!set_event_callback}. *) "; generate_ocaml_structure_decls (); @@ -115,8 +127,8 @@ val clear_progress_callback : t -> unit class guestfs : unit -> object method close : unit -> unit - method set_progress_callback : progress_cb -> unit - method clear_progress_callback : unit -> unit + method set_event_callback : event_callback -> event list -> event_handle + method delete_event_callback : event_handle -> unit method ocaml_handle : t "; @@ -147,12 +159,34 @@ exception Handle_closed of string external create : unit -> t = \"ocaml_guestfs_create\" external close : t -> unit = \"ocaml_guestfs_close\" -type progress_cb = int -> int -> int64 -> int64 -> unit +type event = +"; + List.iter ( + fun (name, _) -> + pr " | EVENT_%s\n" (String.uppercase name) + ) events; + pr "\n"; + + pr "\ +let event_all = [ +"; + List.iter ( + fun (name, _) -> + pr " EVENT_%s;\n" (String.uppercase name) + ) events; + + pr "\ +] + +type event_handle = int + +type event_callback = + t -> event -> event_handle -> string -> int64 array -> unit -external set_progress_callback : t -> progress_cb -> unit - = \"ocaml_guestfs_set_progress_callback\" -external clear_progress_callback : t -> unit - = \"ocaml_guestfs_clear_progress_callback\" +external set_event_callback : t -> event_callback -> event list -> event_handle + = \"ocaml_guestfs_set_event_callback\" +external delete_event_callback : t -> event_handle -> unit + = \"ocaml_guestfs_delete_event_callback\" (* Give the exceptions names, so they can be raised from the C code. *) let () = @@ -175,8 +209,8 @@ class guestfs () = let g = create () in object method close () = close g - method set_progress_callback = set_progress_callback g - method clear_progress_callback () = clear_progress_callback g + method set_event_callback = set_event_callback g + method delete_event_callback = delete_event_callback g method ocaml_handle = g "; diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index 70081662..c07b9c57 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -66,12 +66,14 @@ TESTS = run-bindtests \ t/guestfs_010_basic \ t/guestfs_070_threads \ t/guestfs_080_optargs \ + t/guestfs_400_events \ t/guestfs_400_progress noinst_DATA += bindtests \ t/guestfs_005_load \ t/guestfs_010_basic \ t/guestfs_070_threads \ t/guestfs_080_optargs \ + t/guestfs_400_events \ t/guestfs_400_progress bindtests: bindtests.cmx mlguestfs.cmxa @@ -94,6 +96,10 @@ t/guestfs_080_optargs: t/guestfs_080_optargs.cmx mlguestfs.cmxa mkdir -p t $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package unix -linkpkg mlguestfs.cmxa $< -o $@ +t/guestfs_400_events: t/guestfs_400_events.cmx mlguestfs.cmxa + mkdir -p t + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package unix -linkpkg mlguestfs.cmxa $< -o $@ + t/guestfs_400_progress: t/guestfs_400_progress.cmx mlguestfs.cmxa mkdir -p t $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package unix -linkpkg mlguestfs.cmxa $< -o $@ diff --git a/ocaml/guestfs_c.c b/ocaml/guestfs_c.c index 1324fb69..a1386ec7 100644 --- a/ocaml/guestfs_c.c +++ b/ocaml/guestfs_c.c @@ -1,5 +1,5 @@ /* libguestfs - * Copyright (C) 2009-2010 Red Hat Inc. + * Copyright (C) 2009-2011 Red Hat Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -35,8 +35,8 @@ #include "guestfs_c.h" -static void clear_progress_callback (guestfs_h *g); -static void progress_callback (guestfs_h *g, void *data, int proc_nr, int serial, uint64_t position, uint64_t total); +static value **get_all_event_callbacks (guestfs_h *g, size_t *len_rtn); +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); /* This macro was added in OCaml 3.10. Backport for earlier versions. */ #ifndef CAMLreturnT @@ -50,17 +50,39 @@ static void progress_callback (guestfs_h *g, void *data, int proc_nr, int serial /* These prototypes are solely to quiet gcc warning. */ CAMLprim value ocaml_guestfs_create (void); CAMLprim value ocaml_guestfs_close (value gv); -CAMLprim value ocaml_guestfs_set_progress_callback (value gv, value closure); -CAMLprim value ocaml_guestfs_clear_progress_callback (value gv); +CAMLprim value ocaml_guestfs_set_event_callback (value gv, value closure, value events); +CAMLprim value ocaml_guestfs_delete_event_callback (value gv, value eh); /* Allocate handles and deal with finalization. */ static void guestfs_finalize (value gv) { guestfs_h *g = Guestfs_val (gv); + if (g) { - clear_progress_callback (g); + /* There is a nasty, difficult to solve case here where the + * user deletes events in one of the callbacks that we are + * about to invoke, resulting in a double-free. XXX + */ + size_t len, i; + value **roots = get_all_event_callbacks (g, &len); + + value *v = guestfs_get_private (g, "_ocaml_g"); + + /* Close the handle: this could invoke callbacks from the list + * above, which is why we don't want to delete them before + * closing the handle. + */ guestfs_close (g); + + /* Now unregister the global roots. */ + for (i = 0; i < len; ++i) { + caml_remove_global_root (roots[i]); + free (roots[i]); + } + + caml_remove_global_root (v); + free (v); } } @@ -121,6 +143,7 @@ ocaml_guestfs_create (void) CAMLparam0 (); CAMLlocal1 (gv); guestfs_h *g; + value *v; g = guestfs_create (); if (g == NULL) @@ -129,6 +152,18 @@ ocaml_guestfs_create (void) guestfs_set_error_handler (g, NULL, NULL); gv = Val_guestfs (g); + + /* Store the OCaml handle into the C handle. This is only so we can + * map the C handle to the OCaml handle in event_callback_wrapper. + */ + v = guestfs_safe_malloc (g, sizeof *v); + *v = gv; + /* XXX This global root is generational, but we cannot rely on every + * user having the OCaml 3.11 version which supports this. + */ + caml_register_global_root (v); + guestfs_set_private (g, "_ocaml_g", v); + CAMLreturn (gv); } @@ -173,80 +208,166 @@ ocaml_guestfs_free_strings (char **argv) free (argv); } -#define PROGRESS_ROOT_KEY "_ocaml_progress_root" +static uint64_t +event_bitmask_of_event_list (value events) +{ + uint64_t r = 0; + + while (events != Val_int (0)) { + r |= UINT64_C(1) << Int_val (Field (events, 0)); + events = Field (events, 1); + } + + return r; +} -/* Guestfs.set_progress_callback */ +/* Guestfs.set_event_callback */ CAMLprim value -ocaml_guestfs_set_progress_callback (value gv, value closure) +ocaml_guestfs_set_event_callback (value gv, value closure, value events) { - CAMLparam2 (gv, closure); + CAMLparam3 (gv, closure, events); + char key[64]; + int eh; + uint64_t event_bitmask; guestfs_h *g = Guestfs_val (gv); - clear_progress_callback (g); + + event_bitmask = event_bitmask_of_event_list (events); value *root = guestfs_safe_malloc (g, sizeof *root); *root = closure; + eh = guestfs_set_event_callback (g, event_callback_wrapper, + event_bitmask, 0, root); + + if (eh == -1) { + free (root); + ocaml_guestfs_raise_error (g, "set_event_callback"); + } + /* XXX This global root is generational, but we cannot rely on every * user having the OCaml 3.11 version which supports this. */ caml_register_global_root (root); - guestfs_set_private (g, PROGRESS_ROOT_KEY, root); - - guestfs_set_progress_callback (g, progress_callback, root); + snprintf (key, sizeof key, "_ocaml_event_%d", eh); + guestfs_set_private (g, key, root); - CAMLreturn (Val_unit); + CAMLreturn (Val_int (eh)); } -/* Guestfs.clear_progress_callback */ +/* Guestfs.delete_event_callback */ CAMLprim value -ocaml_guestfs_clear_progress_callback (value gv) +ocaml_guestfs_delete_event_callback (value gv, value ehv) { - CAMLparam1 (gv); + CAMLparam2 (gv, ehv); + char key[64]; + int eh = Int_val (ehv); guestfs_h *g = Guestfs_val (gv); - clear_progress_callback (g); + + snprintf (key, sizeof key, "_ocaml_event_%d", eh); + + value *root = guestfs_get_private (g, key); + if (root) { + caml_remove_global_root (root); + free (root); + guestfs_set_private (g, key, NULL); + guestfs_delete_event_callback (g, eh); + } CAMLreturn (Val_unit); } -static void -clear_progress_callback (guestfs_h *g) +static value ** +get_all_event_callbacks (guestfs_h *g, size_t *len_rtn) { - guestfs_set_progress_callback (g, NULL, NULL); + value **r; + size_t i; + const char *key; + value *root; + + /* Count the length of the array that will be needed. */ + *len_rtn = 0; + root = guestfs_first_private (g, &key); + while (root != NULL) { + if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) + (*len_rtn)++; + root = guestfs_next_private (g, &key); + } - value *root = guestfs_get_private (g, PROGRESS_ROOT_KEY); - if (root) { - caml_remove_global_root (root); - free (root); - guestfs_set_private (g, PROGRESS_ROOT_KEY, NULL); + /* Copy them into the return array. */ + r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn)); + + i = 0; + root = guestfs_first_private (g, &key); + while (root != NULL) { + if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) { + r[i] = root; + i++; + } + root = guestfs_next_private (g, &key); } + + return r; +} + +/* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */ +static int +event_bitmask_to_event (uint64_t event) +{ + int r = 0; + + while (event >>= 1) + r++; + + return r; } static void -progress_callback (guestfs_h *g ATTRIBUTE_UNUSED, void *root, - int proc_nr, int serial, uint64_t position, uint64_t total) +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) { CAMLparam0 (); - CAMLlocal5 (proc_nrv, serialv, positionv, totalv, rv); + CAMLlocal5 (gv, evv, ehv, bufv, arrayv); + CAMLlocal2 (rv, v); + value *root; + size_t i; - proc_nrv = Val_int (proc_nr); - serialv = Val_int (serial); - positionv = caml_copy_int64 (position); - totalv = caml_copy_int64 (total); + root = guestfs_get_private (g, "_ocaml_g"); + gv = *root; + + /* Only one bit should be set in 'event'. Which one? */ + evv = Val_int (event_bitmask_to_event (event)); + + ehv = Val_int (event_handle); + + bufv = caml_alloc_string (buf_len); + memcpy (String_val (bufv), buf, buf_len); + + arrayv = caml_alloc (array_len, 0); + for (i = 0; i < array_len; ++i) { + v = caml_copy_int64 (array[i]); + Store_field (arrayv, i, v); + } - value args[4] = { proc_nrv, serialv, positionv, totalv }; + value args[5] = { gv, evv, ehv, bufv, arrayv }; caml_leave_blocking_section (); - rv = caml_callbackN_exn (*(value*)root, 4, args); + rv = caml_callbackN_exn (*(value*)data, 5, args); caml_enter_blocking_section (); /* Callbacks shouldn't throw exceptions. There's not much we can do * except to print it. */ if (Is_exception_result (rv)) - fprintf (stderr, "libguestfs: uncaught OCaml exception in progress callback: %s", + fprintf (stderr, + "libguestfs: uncaught OCaml exception in event callback: %s", caml_format_exception (Extract_exception (rv))); CAMLreturn0; diff --git a/ocaml/guestfs_c.h b/ocaml/guestfs_c.h index 219dc2fe..a374bf26 100644 --- a/ocaml/guestfs_c.h +++ b/ocaml/guestfs_c.h @@ -1,5 +1,5 @@ /* libguestfs - * Copyright (C) 2009 Red Hat Inc. + * Copyright (C) 2009-2011 Red Hat Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public diff --git a/ocaml/t/guestfs_400_events.ml b/ocaml/t/guestfs_400_events.ml new file mode 100644 index 00000000..7bd77159 --- /dev/null +++ b/ocaml/t/guestfs_400_events.ml @@ -0,0 +1,71 @@ +(* libguestfs OCaml bindings + * Copyright (C) 2011 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + *) + +open Printf + +let log g ev eh buf array = + let ev = + match ev with + | Guestfs.EVENT_CLOSE -> "close" + | Guestfs.EVENT_SUBPROCESS_QUIT -> "subprocess_quit" + | Guestfs.EVENT_LAUNCH_DONE -> "launch_done" + | Guestfs.EVENT_PROGRESS -> "progress" + | Guestfs.EVENT_APPLIANCE -> "appliance" + | Guestfs.EVENT_LIBRARY -> "library" + | Guestfs.EVENT_TRACE -> "trace" in + + let eh : int = Obj.magic eh in + + printf "ocaml event logged: event=%s eh=%d buf=%S array=[%s]\n" + ev eh buf + (String.concat ", " (List.map Int64.to_string (Array.to_list array))) + +let close_invoked = ref 0 + +let close g ev eh buf array = + incr close_invoked; + log g ev eh buf array + +let () = + let g = new Guestfs.guestfs () in + + (* Grab log, trace and daemon messages into our own custom handler + * which prints the messages with a particular prefix. + *) + let events = [Guestfs.EVENT_APPLIANCE; Guestfs.EVENT_LIBRARY; + Guestfs.EVENT_TRACE] in + ignore (g#set_event_callback log events); + + (* Check that the close event is invoked. *) + ignore (g#set_event_callback close [Guestfs.EVENT_CLOSE]); + + (* Now make sure we see some messages. *) + g#set_trace true; + g#set_verbose true; + + (* Do some stuff. *) + g#add_drive_ro "/dev/null"; + g#set_autosync true; + + (* Close the handle -- should call the close callback. *) + assert (!close_invoked = 0); + g#close (); + assert (!close_invoked = 1); + + (* Run full garbage collection. *) + Gc.compact () diff --git a/ocaml/t/guestfs_400_progress.ml b/ocaml/t/guestfs_400_progress.ml index 7227fac2..f5b4219c 100644 --- a/ocaml/t/guestfs_400_progress.ml +++ b/ocaml/t/guestfs_400_progress.ml @@ -1,5 +1,5 @@ (* libguestfs OCaml bindings - * Copyright (C) 2010 Red Hat Inc. + * Copyright (C) 2010-2011 Red Hat Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -25,15 +25,15 @@ let () = G.launch g; let calls = ref 0 in - let cb _ _ _ _ = incr calls in - G.set_progress_callback g cb; + let cb _ _ _ _ _ = incr calls in + let eh = G.set_event_callback g cb [G.EVENT_PROGRESS] in assert ("ok" = G.debug g "progress" [| "5" |]); assert (!calls > 0); calls := 0; - G.clear_progress_callback g; + G.delete_event_callback g eh; assert ("ok" = G.debug g "progress" [| "5" |]); assert (!calls = 0); - G.set_progress_callback g cb; + ignore (G.set_event_callback g cb [G.EVENT_PROGRESS]); assert ("ok" = G.debug g "progress" [| "5" |]); assert (!calls > 0); |