NFC: Allow multiple config files in inspect_with_augeas in inspect_fs_unix.c
[libguestfs.git] / ocaml / guestfs_c.c
1 /* libguestfs
2  * Copyright (C) 2009-2011 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 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);
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_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);
57
58 /* Allocate handles and deal with finalization. */
59 static void
60 guestfs_finalize (value gv)
61 {
62   guestfs_h *g = Guestfs_val (gv);
63
64   if (g) {
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
68      */
69     size_t len, i;
70     value **roots = get_all_event_callbacks (g, &len);
71
72     value *v = guestfs_get_private (g, "_ocaml_g");
73
74     /* Close the handle: this could invoke callbacks from the list
75      * above, which is why we don't want to delete them before
76      * closing the handle.
77      */
78     guestfs_close (g);
79
80     /* Now unregister the global roots. */
81     for (i = 0; i < len; ++i) {
82       caml_remove_global_root (roots[i]);
83       free (roots[i]);
84     }
85
86     caml_remove_global_root (v);
87     free (v);
88   }
89 }
90
91 static struct custom_operations guestfs_custom_operations = {
92   (char *) "guestfs_custom_operations",
93   guestfs_finalize,
94   custom_compare_default,
95   custom_hash_default,
96   custom_serialize_default,
97   custom_deserialize_default
98 };
99
100 static value
101 Val_guestfs (guestfs_h *g)
102 {
103   CAMLparam0 ();
104   CAMLlocal1 (rv);
105
106   rv = caml_alloc_custom (&guestfs_custom_operations,
107                           sizeof (guestfs_h *), 0, 1);
108   Guestfs_val (rv) = g;
109
110   CAMLreturn (rv);
111 }
112
113 void
114 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
115 {
116   CAMLparam0 ();
117   CAMLlocal1 (v);
118   const char *msg;
119
120   msg = guestfs_last_error (g);
121
122   if (msg)
123     v = caml_copy_string (msg);
124   else
125     v = caml_copy_string (func);
126   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
127   CAMLnoreturn;
128 }
129
130 void
131 ocaml_guestfs_raise_closed (const char *func)
132 {
133   CAMLparam0 ();
134   CAMLlocal1 (v);
135
136   v = caml_copy_string (func);
137   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
138   CAMLnoreturn;
139 }
140
141 /* Guestfs.create */
142 CAMLprim value
143 ocaml_guestfs_create (void)
144 {
145   CAMLparam0 ();
146   CAMLlocal1 (gv);
147   guestfs_h *g;
148   value *v;
149
150   g = guestfs_create ();
151   if (g == NULL)
152     caml_failwith ("failed to create guestfs handle");
153
154   guestfs_set_error_handler (g, NULL, NULL);
155
156   gv = Val_guestfs (g);
157
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.
160    */
161   v = guestfs_safe_malloc (g, sizeof *v);
162   *v = gv;
163   /* XXX This global root is generational, but we cannot rely on every
164    * user having the OCaml 3.11 version which supports this.
165    */
166   caml_register_global_root (v);
167   guestfs_set_private (g, "_ocaml_g", v);
168
169   CAMLreturn (gv);
170 }
171
172 /* Guestfs.close */
173 CAMLprim value
174 ocaml_guestfs_close (value gv)
175 {
176   CAMLparam1 (gv);
177
178   guestfs_finalize (gv);
179
180   /* So we don't double-free in the finalizer. */
181   Guestfs_val (gv) = NULL;
182
183   CAMLreturn (Val_unit);
184 }
185
186 /* Copy string array value. */
187 char **
188 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
189 {
190   CAMLparam1 (sv);
191   char **r;
192   unsigned int i;
193
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)));
197   r[i] = NULL;
198
199   CAMLreturnT (char **, r);
200 }
201
202 /* Free array of strings. */
203 void
204 ocaml_guestfs_free_strings (char **argv)
205 {
206   unsigned int i;
207
208   for (i = 0; argv[i] != NULL; ++i)
209     free (argv[i]);
210   free (argv);
211 }
212
213 static uint64_t
214 event_bitmask_of_event_list (value events)
215 {
216   uint64_t r = 0;
217
218   while (events != Val_int (0)) {
219     r |= UINT64_C(1) << Int_val (Field (events, 0));
220     events = Field (events, 1);
221   }
222
223   return r;
224 }
225
226 /* Guestfs.set_event_callback */
227 CAMLprim value
228 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
229 {
230   CAMLparam3 (gv, closure, events);
231   char key[64];
232   int eh;
233   uint64_t event_bitmask;
234
235   guestfs_h *g = Guestfs_val (gv);
236
237   event_bitmask = event_bitmask_of_event_list (events);
238
239   value *root = guestfs_safe_malloc (g, sizeof *root);
240   *root = closure;
241
242   eh = guestfs_set_event_callback (g, event_callback_wrapper,
243                                    event_bitmask, 0, root);
244
245   if (eh == -1) {
246     free (root);
247     ocaml_guestfs_raise_error (g, "set_event_callback");
248   }
249
250   /* XXX This global root is generational, but we cannot rely on every
251    * user having the OCaml 3.11 version which supports this.
252    */
253   caml_register_global_root (root);
254
255   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
256   guestfs_set_private (g, key, root);
257
258   CAMLreturn (Val_int (eh));
259 }
260
261 /* Guestfs.delete_event_callback */
262 CAMLprim value
263 ocaml_guestfs_delete_event_callback (value gv, value ehv)
264 {
265   CAMLparam2 (gv, ehv);
266   char key[64];
267   int eh = Int_val (ehv);
268
269   guestfs_h *g = Guestfs_val (gv);
270
271   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
272
273   value *root = guestfs_get_private (g, key);
274   if (root) {
275     caml_remove_global_root (root);
276     free (root);
277     guestfs_set_private (g, key, NULL);
278     guestfs_delete_event_callback (g, eh);
279   }
280
281   CAMLreturn (Val_unit);
282 }
283
284 static value **
285 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
286 {
287   value **r;
288   size_t i;
289   const char *key;
290   value *root;
291
292   /* Count the length of the array that will be needed. */
293   *len_rtn = 0;
294   root = guestfs_first_private (g, &key);
295   while (root != NULL) {
296     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
297       (*len_rtn)++;
298     root = guestfs_next_private (g, &key);
299   }
300
301   /* Copy them into the return array. */
302   r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
303
304   i = 0;
305   root = guestfs_first_private (g, &key);
306   while (root != NULL) {
307     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
308       r[i] = root;
309       i++;
310     }
311     root = guestfs_next_private (g, &key);
312   }
313
314   return r;
315 }
316
317 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
318 static int
319 event_bitmask_to_event (uint64_t event)
320 {
321   int r = 0;
322
323   while (event >>= 1)
324     r++;
325
326   return r;
327 }
328
329 static void
330 event_callback_wrapper_locked (guestfs_h *g,
331                                void *data,
332                                uint64_t event,
333                                int event_handle,
334                                int flags,
335                                const char *buf, size_t buf_len,
336                                const uint64_t *array, size_t array_len)
337 {
338   CAMLparam0 ();
339   CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
340   CAMLlocal2 (rv, v);
341   value *root;
342   size_t i;
343
344   root = guestfs_get_private (g, "_ocaml_g");
345   gv = *root;
346
347   /* Only one bit should be set in 'event'.  Which one? */
348   evv = Val_int (event_bitmask_to_event (event));
349
350   ehv = Val_int (event_handle);
351
352   bufv = caml_alloc_string (buf_len);
353   memcpy (String_val (bufv), buf, buf_len);
354
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);
359   }
360
361   value args[5] = { gv, evv, ehv, bufv, arrayv };
362
363   rv = caml_callbackN_exn (*(value*)data, 5, args);
364
365   /* Callbacks shouldn't throw exceptions.  There's not much we can do
366    * except to print it.
367    */
368   if (Is_exception_result (rv))
369     fprintf (stderr,
370              "libguestfs: uncaught OCaml exception in event callback: %s",
371              caml_format_exception (Extract_exception (rv)));
372
373   CAMLreturn0;
374 }
375
376 static void
377 event_callback_wrapper (guestfs_h *g,
378                         void *data,
379                         uint64_t event,
380                         int event_handle,
381                         int flags,
382                         const char *buf, size_t buf_len,
383                         const uint64_t *array, size_t array_len)
384 {
385   /* Ensure we are holding the GC lock before any GC operations are
386    * possible. (RHBZ#725824)
387    */
388   caml_leave_blocking_section ();
389
390   event_callback_wrapper_locked (g, data, event, event_handle, flags,
391                                  buf, buf_len, array, array_len);
392
393   caml_enter_blocking_section ();
394 }
395
396 value
397 ocaml_guestfs_last_errno (value gv)
398 {
399   CAMLparam1 (gv);
400   CAMLlocal1 (rv);
401   int r;
402   guestfs_h *g;
403
404   g = Guestfs_val (gv);
405   if (g == NULL)
406     ocaml_guestfs_raise_closed ("last_errno");
407
408   r = guestfs_last_errno (g);
409
410   rv = Val_int (r);
411   CAMLreturn (rv);
412 }
413
414 /* NB: This is and must remain a "noalloc" function. */
415 value
416 ocaml_guestfs_user_cancel (value gv)
417 {
418   guestfs_h *g = Guestfs_val (gv);
419   if (g)
420     guestfs_user_cancel (g);
421   return Val_unit;
422 }