X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=ocaml%2Fguestfs_c.c;h=7648ba931c1d949e516159486ee8c56391a757e5;hp=291c43085a5ec4b10191f68c9cf5d4dfe7f843bb;hb=641ccab6c3b17f1c94676eab99e8baa9cddf5a0b;hpb=b4d2a01828e5de85e5eee3631f7fe3925a0312ca diff --git a/ocaml/guestfs_c.c b/ocaml/guestfs_c.c index 291c430..7648ba9 100644 --- a/ocaml/guestfs_c.c +++ b/ocaml/guestfs_c.c @@ -1,5 +1,5 @@ /* libguestfs - * Copyright (C) 2009 Red Hat Inc. + * Copyright (C) 2009-2010 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 @@ -16,6 +16,7 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA */ +#include #include #include #include @@ -29,19 +30,42 @@ #include #include #include +#include +#include #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); + +/* This macro was added in OCaml 3.10. Backport for earlier versions. */ +#ifndef CAMLreturnT +#define CAMLreturnT(type, result) do{ \ + type caml__temp_result = (result); \ + caml_local_roots = caml__frame; \ + return (caml__temp_result); \ +}while(0) +#endif + +/* 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); + /* Allocate handles and deal with finalization. */ static void guestfs_finalize (value gv) { guestfs_h *g = Guestfs_val (gv); - if (g) guestfs_close (g); + if (g) { + clear_progress_callback (g); + guestfs_close (g); + } } static struct custom_operations guestfs_custom_operations = { - "guestfs_custom_operations", + (char *) "guestfs_custom_operations", guestfs_finalize, custom_compare_default, custom_hash_default, @@ -62,29 +86,31 @@ Val_guestfs (guestfs_h *g) CAMLreturn (rv); } -/* Handle errors. */ -/* XXX Like the current Perl bindings, this is unsafe in a multi- - * threaded environment. - */ -static char *last_error = NULL; - -static void -error_handler (guestfs_h *g, - void *data, - const char *msg) +void +ocaml_guestfs_raise_error (guestfs_h *g, const char *func) { - if (last_error != NULL) free (last_error); - last_error = strdup (msg); + CAMLparam0 (); + CAMLlocal1 (v); + const char *msg; + + msg = guestfs_last_error (g); + + if (msg) + v = caml_copy_string (msg); + else + v = caml_copy_string (func); + caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v); + CAMLnoreturn; } void -ocaml_guestfs_raise_error (guestfs_h *g, const char *func) +ocaml_guestfs_raise_closed (const char *func) { CAMLparam0 (); CAMLlocal1 (v); - v = caml_copy_string (last_error); - caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v); + v = caml_copy_string (func); + caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v); CAMLnoreturn; } @@ -100,7 +126,7 @@ ocaml_guestfs_create (void) if (g == NULL) caml_failwith ("failed to create guestfs handle"); - guestfs_set_error_handler (g, error_handler, NULL); + guestfs_set_error_handler (g, NULL, NULL); gv = Val_guestfs (g); CAMLreturn (gv); @@ -122,15 +148,15 @@ ocaml_guestfs_close (value gv) /* Copy string array value. */ char ** -ocaml_guestfs_strings_val (value sv) +ocaml_guestfs_strings_val (guestfs_h *g, value sv) { CAMLparam1 (sv); char **r; - int i; + unsigned int i; - r = malloc (sizeof (char *) * (Wosize_val (sv) + 1)); + r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1)); for (i = 0; i < Wosize_val (sv); ++i) - r[i] = String_val (Field (sv, i)); + r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i))); r[i] = NULL; CAMLreturnT (char **, r); @@ -140,8 +166,88 @@ ocaml_guestfs_strings_val (value sv) void ocaml_guestfs_free_strings (char **argv) { - /* Don't free the actual strings - they are String_vals on - * the OCaml heap. - */ + unsigned int i; + + for (i = 0; argv[i] != NULL; ++i) + free (argv[i]); free (argv); } + +#define PROGRESS_ROOT_KEY "_ocaml_progress_root" + +/* Guestfs.set_progress_callback */ +CAMLprim value +ocaml_guestfs_set_progress_callback (value gv, value closure) +{ + CAMLparam2 (gv, closure); + + guestfs_h *g = Guestfs_val (gv); + clear_progress_callback (g); + + value *root = guestfs_safe_malloc (g, sizeof *root); + *root = closure; + + /* 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); + + CAMLreturn (Val_unit); +} + +/* Guestfs.clear_progress_callback */ +CAMLprim value +ocaml_guestfs_clear_progress_callback (value gv) +{ + CAMLparam1 (gv); + + guestfs_h *g = Guestfs_val (gv); + clear_progress_callback (g); + + CAMLreturn (Val_unit); +} + +static void +clear_progress_callback (guestfs_h *g) +{ + guestfs_set_progress_callback (g, NULL, NULL); + + 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); + } +} + +static void +progress_callback (guestfs_h *g, void *root, + int proc_nr, int serial, uint64_t position, uint64_t total) +{ + CAMLparam0 (); + CAMLlocal5 (proc_nrv, serialv, positionv, totalv, rv); + + proc_nrv = Val_int (proc_nr); + serialv = Val_int (serial); + positionv = caml_copy_int64 (position); + totalv = caml_copy_int64 (total); + + value args[4] = { proc_nrv, serialv, positionv, totalv }; + + caml_leave_blocking_section (); + rv = caml_callbackN_exn (*(value*)root, 4, 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", + caml_format_exception (Extract_exception (rv))); + + CAMLreturn0; +}