mkfs: Force mke2fs to create a filesystem even on raw IDE device (RHBZ#690819).
[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
56 /* Allocate handles and deal with finalization. */
57 static void
58 guestfs_finalize (value gv)
59 {
60   guestfs_h *g = Guestfs_val (gv);
61
62   if (g) {
63     /* There is a nasty, difficult to solve case here where the
64      * user deletes events in one of the callbacks that we are
65      * about to invoke, resulting in a double-free.  XXX
66      */
67     size_t len, i;
68     value **roots = get_all_event_callbacks (g, &len);
69
70     value *v = guestfs_get_private (g, "_ocaml_g");
71
72     /* Close the handle: this could invoke callbacks from the list
73      * above, which is why we don't want to delete them before
74      * closing the handle.
75      */
76     guestfs_close (g);
77
78     /* Now unregister the global roots. */
79     for (i = 0; i < len; ++i) {
80       caml_remove_global_root (roots[i]);
81       free (roots[i]);
82     }
83
84     caml_remove_global_root (v);
85     free (v);
86   }
87 }
88
89 static struct custom_operations guestfs_custom_operations = {
90   (char *) "guestfs_custom_operations",
91   guestfs_finalize,
92   custom_compare_default,
93   custom_hash_default,
94   custom_serialize_default,
95   custom_deserialize_default
96 };
97
98 static value
99 Val_guestfs (guestfs_h *g)
100 {
101   CAMLparam0 ();
102   CAMLlocal1 (rv);
103
104   rv = caml_alloc_custom (&guestfs_custom_operations,
105                           sizeof (guestfs_h *), 0, 1);
106   Guestfs_val (rv) = g;
107
108   CAMLreturn (rv);
109 }
110
111 void
112 ocaml_guestfs_raise_error (guestfs_h *g, const char *func)
113 {
114   CAMLparam0 ();
115   CAMLlocal1 (v);
116   const char *msg;
117
118   msg = guestfs_last_error (g);
119
120   if (msg)
121     v = caml_copy_string (msg);
122   else
123     v = caml_copy_string (func);
124   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v);
125   CAMLnoreturn;
126 }
127
128 void
129 ocaml_guestfs_raise_closed (const char *func)
130 {
131   CAMLparam0 ();
132   CAMLlocal1 (v);
133
134   v = caml_copy_string (func);
135   caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_closed"), v);
136   CAMLnoreturn;
137 }
138
139 /* Guestfs.create */
140 CAMLprim value
141 ocaml_guestfs_create (void)
142 {
143   CAMLparam0 ();
144   CAMLlocal1 (gv);
145   guestfs_h *g;
146   value *v;
147
148   g = guestfs_create ();
149   if (g == NULL)
150     caml_failwith ("failed to create guestfs handle");
151
152   guestfs_set_error_handler (g, NULL, NULL);
153
154   gv = Val_guestfs (g);
155
156   /* Store the OCaml handle into the C handle.  This is only so we can
157    * map the C handle to the OCaml handle in event_callback_wrapper.
158    */
159   v = guestfs_safe_malloc (g, sizeof *v);
160   *v = gv;
161   /* XXX This global root is generational, but we cannot rely on every
162    * user having the OCaml 3.11 version which supports this.
163    */
164   caml_register_global_root (v);
165   guestfs_set_private (g, "_ocaml_g", v);
166
167   CAMLreturn (gv);
168 }
169
170 /* Guestfs.close */
171 CAMLprim value
172 ocaml_guestfs_close (value gv)
173 {
174   CAMLparam1 (gv);
175
176   guestfs_finalize (gv);
177
178   /* So we don't double-free in the finalizer. */
179   Guestfs_val (gv) = NULL;
180
181   CAMLreturn (Val_unit);
182 }
183
184 /* Copy string array value. */
185 char **
186 ocaml_guestfs_strings_val (guestfs_h *g, value sv)
187 {
188   CAMLparam1 (sv);
189   char **r;
190   unsigned int i;
191
192   r = guestfs_safe_malloc (g, sizeof (char *) * (Wosize_val (sv) + 1));
193   for (i = 0; i < Wosize_val (sv); ++i)
194     r[i] = guestfs_safe_strdup (g, String_val (Field (sv, i)));
195   r[i] = NULL;
196
197   CAMLreturnT (char **, r);
198 }
199
200 /* Free array of strings. */
201 void
202 ocaml_guestfs_free_strings (char **argv)
203 {
204   unsigned int i;
205
206   for (i = 0; argv[i] != NULL; ++i)
207     free (argv[i]);
208   free (argv);
209 }
210
211 static uint64_t
212 event_bitmask_of_event_list (value events)
213 {
214   uint64_t r = 0;
215
216   while (events != Val_int (0)) {
217     r |= UINT64_C(1) << Int_val (Field (events, 0));
218     events = Field (events, 1);
219   }
220
221   return r;
222 }
223
224 /* Guestfs.set_event_callback */
225 CAMLprim value
226 ocaml_guestfs_set_event_callback (value gv, value closure, value events)
227 {
228   CAMLparam3 (gv, closure, events);
229   char key[64];
230   int eh;
231   uint64_t event_bitmask;
232
233   guestfs_h *g = Guestfs_val (gv);
234
235   event_bitmask = event_bitmask_of_event_list (events);
236
237   value *root = guestfs_safe_malloc (g, sizeof *root);
238   *root = closure;
239
240   eh = guestfs_set_event_callback (g, event_callback_wrapper,
241                                    event_bitmask, 0, root);
242
243   if (eh == -1) {
244     free (root);
245     ocaml_guestfs_raise_error (g, "set_event_callback");
246   }
247
248   /* XXX This global root is generational, but we cannot rely on every
249    * user having the OCaml 3.11 version which supports this.
250    */
251   caml_register_global_root (root);
252
253   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
254   guestfs_set_private (g, key, root);
255
256   CAMLreturn (Val_int (eh));
257 }
258
259 /* Guestfs.delete_event_callback */
260 CAMLprim value
261 ocaml_guestfs_delete_event_callback (value gv, value ehv)
262 {
263   CAMLparam2 (gv, ehv);
264   char key[64];
265   int eh = Int_val (ehv);
266
267   guestfs_h *g = Guestfs_val (gv);
268
269   snprintf (key, sizeof key, "_ocaml_event_%d", eh);
270
271   value *root = guestfs_get_private (g, key);
272   if (root) {
273     caml_remove_global_root (root);
274     free (root);
275     guestfs_set_private (g, key, NULL);
276     guestfs_delete_event_callback (g, eh);
277   }
278
279   CAMLreturn (Val_unit);
280 }
281
282 static value **
283 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
284 {
285   value **r;
286   size_t i;
287   const char *key;
288   value *root;
289
290   /* Count the length of the array that will be needed. */
291   *len_rtn = 0;
292   root = guestfs_first_private (g, &key);
293   while (root != NULL) {
294     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0)
295       (*len_rtn)++;
296     root = guestfs_next_private (g, &key);
297   }
298
299   /* Copy them into the return array. */
300   r = guestfs_safe_malloc (g, sizeof (value *) * (*len_rtn));
301
302   i = 0;
303   root = guestfs_first_private (g, &key);
304   while (root != NULL) {
305     if (strncmp (key, "_ocaml_event_", strlen ("_ocaml_event_")) == 0) {
306       r[i] = root;
307       i++;
308     }
309     root = guestfs_next_private (g, &key);
310   }
311
312   return r;
313 }
314
315 /* Could do better: http://graphics.stanford.edu/~seander/bithacks.html */
316 static int
317 event_bitmask_to_event (uint64_t event)
318 {
319   int r = 0;
320
321   while (event >>= 1)
322     r++;
323
324   return r;
325 }
326
327 static void
328 event_callback_wrapper (guestfs_h *g,
329                         void *data,
330                         uint64_t event,
331                         int event_handle,
332                         int flags,
333                         const char *buf, size_t buf_len,
334                         const uint64_t *array, size_t array_len)
335 {
336   CAMLparam0 ();
337   CAMLlocal5 (gv, evv, ehv, bufv, arrayv);
338   CAMLlocal2 (rv, v);
339   value *root;
340   size_t i;
341
342   root = guestfs_get_private (g, "_ocaml_g");
343   gv = *root;
344
345   /* Only one bit should be set in 'event'.  Which one? */
346   evv = Val_int (event_bitmask_to_event (event));
347
348   ehv = Val_int (event_handle);
349
350   bufv = caml_alloc_string (buf_len);
351   memcpy (String_val (bufv), buf, buf_len);
352
353   arrayv = caml_alloc (array_len, 0);
354   for (i = 0; i < array_len; ++i) {
355     v = caml_copy_int64 (array[i]);
356     Store_field (arrayv, i, v);
357   }
358
359   value args[5] = { gv, evv, ehv, bufv, arrayv };
360
361   caml_leave_blocking_section ();
362   rv = caml_callbackN_exn (*(value*)data, 5, args);
363   caml_enter_blocking_section ();
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 }