ocaml/guestfs_c.c

   1 /* libguestfs
   2  * Copyright (C) 2009-2010 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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
  17  */
  18
  19 #include <config.h>
  20 #include <stdio.h>
  21 #include <stdlib.h>
  22 #include <string.h>
  23
  24 #include <guestfs.h>
  25
  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>
  35
  36 #include "guestfs_c.h"
  37
  38 static void clear_progress_callback (guestfs_h *g);
  39 static void progress_callback (guestfs_h *g, void *data, int proc_nr, int serial, uint64_t position, uint64_t total);
  40
  41 /* This macro was added in OCaml 3.10.  Backport for earlier versions. */
  42 #ifndef CAMLreturnT
  43 #define CAMLreturnT(type, result) do{ \
  44   type caml__temp_result = (result); \
  45   caml_local_roots = caml__frame; \
  46   return (caml__temp_result); \
  47 }while(0)
  48 #endif
  49
  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_progress_callback (value gv, value closure);
  54 CAMLprim value ocaml_guestfs_clear_progress_callback (value gv);
  55
  56 /* Allocate handles and deal with finalization. */
  57 static void
  58 guestfs_finalize (value gv)
  59 {
  60   guestfs_h *g = Guestfs_val (gv);
  61   if (g) {
  62     clear_progress_callback (g);
  63     guestfs_close (g);
  64   }
  65 }
  66
  67 static struct custom_operations guestfs_custom_operations = {
  68   (char *) "guestfs_custom_operations",
  69   guestfs_finalize,
  70   custom_compare_default,
  71   custom_hash_default,
  72   custom_serialize_default,
  73   custom_deserialize_default
  74 };
  75
  76 static value
  77 Val_guestfs (guestfs_h *g)
  78 {
  79   CAMLparam0 ();
  80   CAMLlocal1 (rv);
  81
  82   rv = caml_alloc_custom (&guestfs_custom_operations,
  83                           sizeof (guestfs_h *), 0, 1);
  84   Guestfs_val (rv) = g;
  85
  86   CAMLreturn (rv);
  87 }
  88
  89 void
  90 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
  91 {
  92   CAMLparam0 ();
  93   CAMLlocal1 (v);
  94   const char *msg;
  95
  96   msg = guestfs_last_error (g);
  97
  98   if (msg)
  99     v = caml_copy_string (msg);
 100   else
 101     v = caml_copy_string (func);
 102   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
 103   CAMLnoreturn;
 104 }
 105
 106 void
 107 ocaml_guestfs_raise_closed (const char *func)
 108 {
 109   CAMLparam0 ();
 110   CAMLlocal1 (v);
 111
 112   v = caml_copy_string (func);
 113   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
 114   CAMLnoreturn;
 115 }
 116
 117 /* Guestfs.create */
 118 CAMLprim value
 119 ocaml_guestfs_create (void)
 120 {
 121   CAMLparam0 ();
 122   CAMLlocal1 (gv);
 123   guestfs_h *g;
 124
 125   g = guestfs_create ();
 126   if (g == NULL)
 127     caml_failwith ("failed to create guestfs handle");
 128
 129   guestfs_set_error_handler (g, NULL, NULL);
 130
 131   gv = Val_guestfs (g);
 132   CAMLreturn (gv);
 133 }
 134
 135 /* Guestfs.close */
 136 CAMLprim value
 137 ocaml_guestfs_close (value gv)
 138 {
 139   CAMLparam1 (gv);
 140
 141   guestfs_finalize (gv);
 142
 143   /* So we don't double-free in the finalizer. */
 144   Guestfs_val (gv) = NULL;
 145
 146   CAMLreturn (Val_unit);
 147 }
 148
 149 /* Copy string array value. */
 150 char **
 151 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
 152 {
 153   CAMLparam1 (sv);
 154   char **r;
 155   unsigned int i;
 156
 157   r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
 158   for (i = 0; i < Wosize_val (sv); ++i)
 159     r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
 160   r[i] = NULL;
 161
 162   CAMLreturnT (char **, r);
 163 }
 164
 165 /* Free array of strings. */
 166 void
 167 ocaml_guestfs_free_strings (char **argv)
 168 {
 169   unsigned int i;
 170
 171   for (i = 0; argv[i] != NULL; ++i)
 172     free (argv[i]);
 173   free (argv);
 174 }
 175
 176 #define PROGRESS_ROOT_KEY "_ocaml_progress_root"
 177
 178 /* Guestfs.set_progress_callback */
 179 CAMLprim value
 180 ocaml_guestfs_set_progress_callback (value gv, value closure)
 181 {
 182   CAMLparam2 (gv, closure);
 183
 184   guestfs_h *g = Guestfs_val (gv);
 185   clear_progress_callback (g);
 186
 187   value *root = guestfs_safe_malloc (g, sizeof *root);
 188   *root = closure;
 189
 190   /* XXX This global root is generational, but we cannot rely on every
 191    * user having the OCaml 3.11 version which supports this.
 192    */
 193   caml_register_global_root (root);
 194
 195   guestfs_set_private (g, PROGRESS_ROOT_KEY, root);
 196
 197   guestfs_set_progress_callback (g, progress_callback, root);
 198
 199   CAMLreturn (Val_unit);
 200 }
 201
 202 /* Guestfs.clear_progress_callback */
 203 CAMLprim value
 204 ocaml_guestfs_clear_progress_callback (value gv)
 205 {
 206   CAMLparam1 (gv);
 207
 208   guestfs_h *g = Guestfs_val (gv);
 209   clear_progress_callback (g);
 210
 211   CAMLreturn (Val_unit);
 212 }
 213
 214 static void
 215 clear_progress_callback (guestfs_h *g)
 216 {
 217   guestfs_set_progress_callback (g, NULL, NULL);
 218
 219   value *root = guestfs_get_private (g, PROGRESS_ROOT_KEY);
 220   if (root) {
 221     caml_remove_global_root (root);
 222     free (root);
 223     guestfs_set_private (g, PROGRESS_ROOT_KEY, NULL);
 224   }
 225 }
 226
 227 static void
 228 progress_callback_locked (guestfs_h *g ATTRIBUTE_UNUSED, void *root,
 229                           int proc_nr, int serial, uint64_t position, uint64_t total)
 230 {
 231   CAMLparam0 ();
 232   CAMLlocal5 (proc_nrv, serialv, positionv, totalv, rv);
 233
 234   proc_nrv = Val_int (proc_nr);
 235   serialv = Val_int (serial);
 236   positionv = caml_copy_int64 (position);
 237   totalv = caml_copy_int64 (total);
 238
 239   value args[4] = { proc_nrv, serialv, positionv, totalv };
 240
 241   rv = caml_callbackN_exn (*(value*)root, 4, args);
 242
 243   /* Callbacks shouldn't throw exceptions.  There's not much we can do
 244    * except to print it.
 245    */
 246   if (Is_exception_result (rv))
 247     fprintf (stderr, "libguestfs: uncaught OCaml exception in progress callback: %s",
 248              caml_format_exception (Extract_exception (rv)));
 249
 250   CAMLreturn0;
 251 }
 252
 253 static void
 254 progress_callback (guestfs_h *g ATTRIBUTE_UNUSED, void *root,
 255                    int proc_nr, int serial, uint64_t position, uint64_t total)
 256 {
 257   /* Ensure we are holding the GC lock before any GC operations are
 258    * possible. (RHBZ#725824)
 259    */
 260   caml_leave_blocking_section ();
 261
 262   progress_callback_locked (g, root, proc_nr, serial, position, total);
 263
 264   caml_enter_blocking_section ();
 265 }