From: Richard Jones Date: Wed, 8 Apr 2009 21:52:11 +0000 (+0100) Subject: OCaml bindings compile. X-Git-Tag: 0.6~2 X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=commitdiff_plain;h=13339826ea01f8dbd581b5d2544e7692171cf386 OCaml bindings compile. --- diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index 62ffe2b..ca8a0ac 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -31,10 +31,10 @@ mlguestfs.cmxa: guestfs_c.o guestfs_c_actions.o guestfs.cmx $(OCAMLMKLIB) -o mlguestfs $^ -lguestfs guestfs_c.o: guestfs_c.c - $(CC) $(CFLAGS) -I$(OCAMLLIB) -c $< + $(CC) $(CFLAGS) -I$(OCAMLLIB) -I$(top_builddir)/src -fPIC -Wall -c $< guestfs_c_actions.o: guestfs_c_actions.c - $(CC) $(CFLAGS) -I$(OCAMLLIB) -c $< + $(CC) $(CFLAGS) -I$(OCAMLLIB) -I$(top_builddir)/src -fPIC -Wall -c $< .mli.cmi: $(OCAMLFIND) ocamlc -c $< diff --git a/ocaml/guestfs.ml b/ocaml/guestfs.ml index dd60c53..3e9f172 100644 --- a/ocaml/guestfs.ml +++ b/ocaml/guestfs.ml @@ -22,7 +22,10 @@ type t exception Error of string external create : unit -> t = "ocaml_guestfs_create" -external close : t -> unit = "ocaml_guestfs_create" +external close : t -> unit = "ocaml_guestfs_close" + +let () = + Callback.register_exception "ocaml_guestfs_error" (Error "") type lvm_pv = { pv_name : string; @@ -99,12 +102,12 @@ external sync : t -> unit = "ocaml_guestfs_sync" external touch : t -> string -> unit = "ocaml_guestfs_touch" external cat : t -> string -> string = "ocaml_guestfs_cat" external ll : t -> string -> string = "ocaml_guestfs_ll" -external ls : t -> string -> string list = "ocaml_guestfs_ls" -external list_devices : t -> string list = "ocaml_guestfs_list_devices" -external list_partitions : t -> string list = "ocaml_guestfs_list_partitions" -external pvs : t -> string list = "ocaml_guestfs_pvs" -external vgs : t -> string list = "ocaml_guestfs_vgs" -external lvs : t -> string list = "ocaml_guestfs_lvs" -external pvs_full : t -> lvm_pv list = "ocaml_guestfs_pvs_full" -external vgs_full : t -> lvm_vg list = "ocaml_guestfs_vgs_full" -external lvs_full : t -> lvm_lv list = "ocaml_guestfs_lvs_full" +external ls : t -> string -> string array = "ocaml_guestfs_ls" +external list_devices : t -> string array = "ocaml_guestfs_list_devices" +external list_partitions : t -> string array = "ocaml_guestfs_list_partitions" +external pvs : t -> string array = "ocaml_guestfs_pvs" +external vgs : t -> string array = "ocaml_guestfs_vgs" +external lvs : t -> string array = "ocaml_guestfs_lvs" +external pvs_full : t -> lvm_pv array = "ocaml_guestfs_pvs_full" +external vgs_full : t -> lvm_vg array = "ocaml_guestfs_vgs_full" +external lvs_full : t -> lvm_lv array = "ocaml_guestfs_lvs_full" diff --git a/ocaml/guestfs.mli b/ocaml/guestfs.mli index cef8943..d1970ed 100644 --- a/ocaml/guestfs.mli +++ b/ocaml/guestfs.mli @@ -145,30 +145,30 @@ val cat : t -> string -> string val ll : t -> string -> string (** list the files in a directory (long format) *) -val ls : t -> string -> string list +val ls : t -> string -> string array (** list the files in a directory *) -val list_devices : t -> string list +val list_devices : t -> string array (** list the block devices *) -val list_partitions : t -> string list +val list_partitions : t -> string array (** list the partitions *) -val pvs : t -> string list +val pvs : t -> string array (** list the LVM physical volumes (PVs) *) -val vgs : t -> string list +val vgs : t -> string array (** list the LVM volume groups (VGs) *) -val lvs : t -> string list +val lvs : t -> string array (** list the LVM logical volumes (LVs) *) -val pvs_full : t -> lvm_pv list +val pvs_full : t -> lvm_pv array (** list the LVM physical volumes (PVs) *) -val vgs_full : t -> lvm_vg list +val vgs_full : t -> lvm_vg array (** list the LVM volume groups (VGs) *) -val lvs_full : t -> lvm_lv list +val lvs_full : t -> lvm_lv array (** list the LVM logical volumes (LVs) *) diff --git a/ocaml/guestfs_c.c b/ocaml/guestfs_c.c index dda338f..600440c 100644 --- a/ocaml/guestfs_c.c +++ b/ocaml/guestfs_c.c @@ -18,24 +18,104 @@ #include #include +#include #include #include #include #include +#include #include #include #include #include "guestfs_c.h" +/* Allocate handles and deal with finalization. */ +static void +guestfs_finalize (value gv) +{ + guestfs_h *g = Guestfs_val (gv); + if (g) guestfs_close (g); +} + +static struct custom_operations guestfs_custom_operations = { + "guestfs_custom_operations", + guestfs_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static value +Val_guestfs (guestfs_h *g) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + + rv = caml_alloc_custom (&guestfs_custom_operations, + sizeof (guestfs_h *), 0, 1); + Guestfs_val (rv) = 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) +{ + if (last_error != NULL) free (last_error); + last_error = strdup (msg); +} + +void +ocaml_guestfs_raise_error (guestfs_h *g, const char *func) +{ + CAMLparam0 (); + CAMLlocal1 (v); + + v = caml_copy_string (last_error); + caml_raise_with_arg (*caml_named_value ("ocaml_guestfs_error"), v); + CAMLnoreturn; +} + +/* Guestfs.create */ CAMLprim value -ocaml_guestfs_create (value hv /* XXX */) +ocaml_guestfs_create (void) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam0 (); + CAMLlocal1 (gv); + guestfs_h *g; + + g = guestfs_create (); + if (g == NULL) + caml_failwith ("failed to create guestfs handle"); + + guestfs_set_error_handler (g, error_handler, NULL); + + gv = Val_guestfs (g); + CAMLreturn (gv); } -/* etc */ +/* Guestfs.close */ +CAMLprim value +ocaml_guestfs_close (value gv) +{ + CAMLparam1 (gv); + + guestfs_finalize (gv); + + /* So we don't double-free in the finalizer. */ + Guestfs_val (gv) = NULL; + + CAMLreturn (Val_unit); +} diff --git a/ocaml/guestfs_c.h b/ocaml/guestfs_c.h index 52b5aea..3da41d0 100644 --- a/ocaml/guestfs_c.h +++ b/ocaml/guestfs_c.h @@ -19,6 +19,8 @@ #ifndef GUESTFS_OCAML_C_H #define GUESTFS_OCAML_C_H - +#define Guestfs_val(v) (*((guestfs_h **)Data_custom_val(v))) +extern void ocaml_guestfs_raise_error (guestfs_h *g, const char *func) + Noreturn; #endif /* GUESTFS_OCAML_C_H */ diff --git a/ocaml/guestfs_c_actions.c b/ocaml/guestfs_c_actions.c index c1b4207..64a590f 100644 --- a/ocaml/guestfs_c_actions.c +++ b/ocaml/guestfs_c_actions.c @@ -21,8 +21,7 @@ #include #include - -#include +#include #include #include @@ -30,214 +29,816 @@ #include #include #include +#include + +#include #include "guestfs_c.h" +static CAMLprim value +copy_lvm_pv (const struct guestfs_lvm_pv *pv) +{ + CAMLparam0 (); + CAMLlocal2 (rv, v); + + rv = caml_alloc (14, 0); + v = caml_copy_string (pv->pv_name); + Store_field (rv, 0, v); + v = caml_alloc_string (32); + memcpy (String_val (v), pv->pv_uuid, 32); + Store_field (rv, 1, v); + v = caml_copy_string (pv->pv_fmt); + Store_field (rv, 2, v); + v = caml_copy_int64 (pv->pv_size); + Store_field (rv, 3, v); + v = caml_copy_int64 (pv->dev_size); + Store_field (rv, 4, v); + v = caml_copy_int64 (pv->pv_free); + Store_field (rv, 5, v); + v = caml_copy_int64 (pv->pv_used); + Store_field (rv, 6, v); + v = caml_copy_string (pv->pv_attr); + Store_field (rv, 7, v); + v = caml_copy_int64 (pv->pv_pe_count); + Store_field (rv, 8, v); + v = caml_copy_int64 (pv->pv_pe_alloc_count); + Store_field (rv, 9, v); + v = caml_copy_string (pv->pv_tags); + Store_field (rv, 10, v); + v = caml_copy_int64 (pv->pe_start); + Store_field (rv, 11, v); + v = caml_copy_int64 (pv->pv_mda_count); + Store_field (rv, 12, v); + v = caml_copy_int64 (pv->pv_mda_free); + Store_field (rv, 13, v); + CAMLreturn (rv); +} + +static CAMLprim value +copy_lvm_pv_list (const struct guestfs_lvm_pv_list *pvs) +{ + CAMLparam0 (); + CAMLlocal2 (rv, v); + int i; + + if (pvs->len == 0) + CAMLreturn (Atom (0)); + else { + rv = caml_alloc (pvs->len, 0); + for (i = 0; i < pvs->len; ++i) { + v = copy_lvm_pv (&pvs->val[i]); + caml_modify (&Field (rv, i), v); + } + CAMLreturn (rv); + } +} + +static CAMLprim value +copy_lvm_vg (const struct guestfs_lvm_vg *vg) +{ + CAMLparam0 (); + CAMLlocal2 (rv, v); + + rv = caml_alloc (19, 0); + v = caml_copy_string (vg->vg_name); + Store_field (rv, 0, v); + v = caml_alloc_string (32); + memcpy (String_val (v), vg->vg_uuid, 32); + Store_field (rv, 1, v); + v = caml_copy_string (vg->vg_fmt); + Store_field (rv, 2, v); + v = caml_copy_string (vg->vg_attr); + Store_field (rv, 3, v); + v = caml_copy_int64 (vg->vg_size); + Store_field (rv, 4, v); + v = caml_copy_int64 (vg->vg_free); + Store_field (rv, 5, v); + v = caml_copy_string (vg->vg_sysid); + Store_field (rv, 6, v); + v = caml_copy_int64 (vg->vg_extent_size); + Store_field (rv, 7, v); + v = caml_copy_int64 (vg->vg_extent_count); + Store_field (rv, 8, v); + v = caml_copy_int64 (vg->vg_free_count); + Store_field (rv, 9, v); + v = caml_copy_int64 (vg->max_lv); + Store_field (rv, 10, v); + v = caml_copy_int64 (vg->max_pv); + Store_field (rv, 11, v); + v = caml_copy_int64 (vg->pv_count); + Store_field (rv, 12, v); + v = caml_copy_int64 (vg->lv_count); + Store_field (rv, 13, v); + v = caml_copy_int64 (vg->snap_count); + Store_field (rv, 14, v); + v = caml_copy_int64 (vg->vg_seqno); + Store_field (rv, 15, v); + v = caml_copy_string (vg->vg_tags); + Store_field (rv, 16, v); + v = caml_copy_int64 (vg->vg_mda_count); + Store_field (rv, 17, v); + v = caml_copy_int64 (vg->vg_mda_free); + Store_field (rv, 18, v); + CAMLreturn (rv); +} + +static CAMLprim value +copy_lvm_vg_list (const struct guestfs_lvm_vg_list *vgs) +{ + CAMLparam0 (); + CAMLlocal2 (rv, v); + int i; + + if (vgs->len == 0) + CAMLreturn (Atom (0)); + else { + rv = caml_alloc (vgs->len, 0); + for (i = 0; i < vgs->len; ++i) { + v = copy_lvm_vg (&vgs->val[i]); + caml_modify (&Field (rv, i), v); + } + CAMLreturn (rv); + } +} + +static CAMLprim value +copy_lvm_lv (const struct guestfs_lvm_lv *lv) +{ + CAMLparam0 (); + CAMLlocal3 (rv, v, v2); + + rv = caml_alloc (16, 0); + v = caml_copy_string (lv->lv_name); + Store_field (rv, 0, v); + v = caml_alloc_string (32); + memcpy (String_val (v), lv->lv_uuid, 32); + Store_field (rv, 1, v); + v = caml_copy_string (lv->lv_attr); + Store_field (rv, 2, v); + v = caml_copy_int64 (lv->lv_major); + Store_field (rv, 3, v); + v = caml_copy_int64 (lv->lv_minor); + Store_field (rv, 4, v); + v = caml_copy_int64 (lv->lv_kernel_major); + Store_field (rv, 5, v); + v = caml_copy_int64 (lv->lv_kernel_minor); + Store_field (rv, 6, v); + v = caml_copy_int64 (lv->lv_size); + Store_field (rv, 7, v); + v = caml_copy_int64 (lv->seg_count); + Store_field (rv, 8, v); + v = caml_copy_string (lv->origin); + Store_field (rv, 9, v); + if (lv->snap_percent >= 0) { /* Some snap_percent */ + v2 = caml_copy_double (lv->snap_percent); + v = caml_alloc (1, 0); + Store_field (v, 0, v2); + } else /* None */ + v = Val_int (0); + Store_field (rv, 10, v); + if (lv->copy_percent >= 0) { /* Some copy_percent */ + v2 = caml_copy_double (lv->copy_percent); + v = caml_alloc (1, 0); + Store_field (v, 0, v2); + } else /* None */ + v = Val_int (0); + Store_field (rv, 11, v); + v = caml_copy_string (lv->move_pv); + Store_field (rv, 12, v); + v = caml_copy_string (lv->lv_tags); + Store_field (rv, 13, v); + v = caml_copy_string (lv->mirror_log); + Store_field (rv, 14, v); + v = caml_copy_string (lv->modules); + Store_field (rv, 15, v); + CAMLreturn (rv); +} + +static CAMLprim value +copy_lvm_lv_list (const struct guestfs_lvm_lv_list *lvs) +{ + CAMLparam0 (); + CAMLlocal2 (rv, v); + int i; + + if (lvs->len == 0) + CAMLreturn (Atom (0)); + else { + rv = caml_alloc (lvs->len, 0); + for (i = 0; i < lvs->len; ++i) { + v = copy_lvm_lv (&lvs->val[i]); + caml_modify (&Field (rv, i), v); + } + CAMLreturn (rv); + } +} + CAMLprim value -ocaml_guestfs_launch (value hv /* XXX */) +ocaml_guestfs_launch (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("launch: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_launch (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "launch"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_wait_ready (value hv /* XXX */) +ocaml_guestfs_wait_ready (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("wait_ready: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_wait_ready (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "wait_ready"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_kill_subprocess (value hv /* XXX */) +ocaml_guestfs_kill_subprocess (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("kill_subprocess: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_kill_subprocess (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "kill_subprocess"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_add_drive (value hv /* XXX */) +ocaml_guestfs_add_drive (value gv, value filenamev) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, filenamev); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("add_drive: used handle after closing it"); + + const char *filename = String_val (filenamev); + int r; + + caml_enter_blocking_section (); + r = guestfs_add_drive (g, filename); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "add_drive"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_add_cdrom (value hv /* XXX */) +ocaml_guestfs_add_cdrom (value gv, value filenamev) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, filenamev); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("add_cdrom: used handle after closing it"); + + const char *filename = String_val (filenamev); + int r; + + caml_enter_blocking_section (); + r = guestfs_add_cdrom (g, filename); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "add_cdrom"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_config (value hv /* XXX */) +ocaml_guestfs_config (value gv, value qemuparamv, value qemuvaluev) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam3 (gv, qemuparamv, qemuvaluev); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("config: used handle after closing it"); + + const char *qemuparam = String_val (qemuparamv); + const char *qemuvalue = + qemuvaluev != Val_int (0) ? String_val (Field (qemuvaluev, 0)) : NULL; + int r; + + caml_enter_blocking_section (); + r = guestfs_config (g, qemuparam, qemuvalue); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "config"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_set_path (value hv /* XXX */) +ocaml_guestfs_set_path (value gv, value pathv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, pathv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("set_path: used handle after closing it"); + + const char *path = String_val (pathv); + int r; + + caml_enter_blocking_section (); + r = guestfs_set_path (g, path); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "set_path"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_get_path (value hv /* XXX */) +ocaml_guestfs_get_path (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("get_path: used handle after closing it"); + + const char *r; + + caml_enter_blocking_section (); + r = guestfs_get_path (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "get_path"); + + rv = caml_copy_string (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_set_autosync (value hv /* XXX */) +ocaml_guestfs_set_autosync (value gv, value autosyncv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, autosyncv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("set_autosync: used handle after closing it"); + + int autosync = Bool_val (autosyncv); + int r; + + caml_enter_blocking_section (); + r = guestfs_set_autosync (g, autosync); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "set_autosync"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_get_autosync (value hv /* XXX */) +ocaml_guestfs_get_autosync (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("get_autosync: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_get_autosync (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "get_autosync"); + + rv = r ? Val_true : Val_false; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_set_verbose (value hv /* XXX */) +ocaml_guestfs_set_verbose (value gv, value verbosev) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, verbosev); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("set_verbose: used handle after closing it"); + + int verbose = Bool_val (verbosev); + int r; + + caml_enter_blocking_section (); + r = guestfs_set_verbose (g, verbose); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "set_verbose"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_get_verbose (value hv /* XXX */) +ocaml_guestfs_get_verbose (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("get_verbose: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_get_verbose (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "get_verbose"); + + rv = r ? Val_true : Val_false; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_mount (value hv /* XXX */) +ocaml_guestfs_mount (value gv, value devicev, value mountpointv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam3 (gv, devicev, mountpointv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("mount: used handle after closing it"); + + const char *device = String_val (devicev); + const char *mountpoint = String_val (mountpointv); + int r; + + caml_enter_blocking_section (); + r = guestfs_mount (g, device, mountpoint); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "mount"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_sync (value hv /* XXX */) +ocaml_guestfs_sync (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("sync: used handle after closing it"); + + int r; + + caml_enter_blocking_section (); + r = guestfs_sync (g); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "sync"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_touch (value hv /* XXX */) +ocaml_guestfs_touch (value gv, value pathv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, pathv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("touch: used handle after closing it"); + + const char *path = String_val (pathv); + int r; + + caml_enter_blocking_section (); + r = guestfs_touch (g, path); + caml_leave_blocking_section (); + if (r == -1) + ocaml_guestfs_raise_error (g, "touch"); + + rv = Val_unit; + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_cat (value hv /* XXX */) +ocaml_guestfs_cat (value gv, value pathv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, pathv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("cat: used handle after closing it"); + + const char *path = String_val (pathv); + char *r; + + caml_enter_blocking_section (); + r = guestfs_cat (g, path); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "cat"); + + rv = caml_copy_string (r); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_ll (value hv /* XXX */) +ocaml_guestfs_ll (value gv, value directoryv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, directoryv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("ll: used handle after closing it"); + + const char *directory = String_val (directoryv); + char *r; + + caml_enter_blocking_section (); + r = guestfs_ll (g, directory); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "ll"); + + rv = caml_copy_string (r); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_ls (value hv /* XXX */) +ocaml_guestfs_ls (value gv, value directoryv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam2 (gv, directoryv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("ls: used handle after closing it"); + + const char *directory = String_val (directoryv); + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_ls (g, directory); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "ls"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_list_devices (value hv /* XXX */) +ocaml_guestfs_list_devices (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("list_devices: used handle after closing it"); + + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_list_devices (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "list_devices"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_list_partitions (value hv /* XXX */) +ocaml_guestfs_list_partitions (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("list_partitions: used handle after closing it"); + + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_list_partitions (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "list_partitions"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_pvs (value hv /* XXX */) +ocaml_guestfs_pvs (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("pvs: used handle after closing it"); + + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_pvs (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "pvs"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_vgs (value hv /* XXX */) +ocaml_guestfs_vgs (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("vgs: used handle after closing it"); + + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_vgs (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "vgs"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_lvs (value hv /* XXX */) +ocaml_guestfs_lvs (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("lvs: used handle after closing it"); + + int i; + char **r; + + caml_enter_blocking_section (); + r = guestfs_lvs (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "lvs"); + + rv = caml_copy_string_array ((const char **) r); + for (i = 0; r[i] != NULL; ++i) free (r[i]); + free (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_pvs_full (value hv /* XXX */) +ocaml_guestfs_pvs_full (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("pvs_full: used handle after closing it"); + + struct guestfs_lvm_pv_list *r; + + caml_enter_blocking_section (); + r = guestfs_pvs_full (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "pvs_full"); + + rv = copy_lvm_pv_list (r); + guestfs_free_lvm_pv_list (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_vgs_full (value hv /* XXX */) +ocaml_guestfs_vgs_full (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("vgs_full: used handle after closing it"); + + struct guestfs_lvm_vg_list *r; + + caml_enter_blocking_section (); + r = guestfs_vgs_full (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "vgs_full"); + + rv = copy_lvm_vg_list (r); + guestfs_free_lvm_vg_list (r); + CAMLreturn (rv); } CAMLprim value -ocaml_guestfs_lvs_full (value hv /* XXX */) +ocaml_guestfs_lvs_full (value gv) { - CAMLparam1 (hv); /* XXX */ -/* XXX write something here */ - CAMLreturn (Val_unit); /* XXX */ + CAMLparam1 (gv); + CAMLlocal1 (rv); + + guestfs_h *g = Guestfs_val (gv); + if (g == NULL) + caml_failwith ("lvs_full: used handle after closing it"); + + struct guestfs_lvm_lv_list *r; + + caml_enter_blocking_section (); + r = guestfs_lvs_full (g); + caml_leave_blocking_section (); + if (r == NULL) + ocaml_guestfs_raise_error (g, "lvs_full"); + + rv = copy_lvm_lv_list (r); + guestfs_free_lvm_lv_list (r); + CAMLreturn (rv); } diff --git a/src/generator.ml b/src/generator.ml index 8ea12a7..95a0985 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -437,6 +437,13 @@ let rec find_map f = function | Some y -> y | None -> find_map f xs +let iteri f xs = + let rec loop i = function + | [] -> () + | x :: xs -> f i x; loop (i+1) xs + in + loop 0 xs + (* 'pr' prints to the current output file. *) let chan = ref stdout let pr fs = ksprintf (output_string !chan) fs @@ -1655,9 +1662,13 @@ and generate_ocaml_ml () = type t exception Error of string external create : unit -> t = \"ocaml_guestfs_create\" -external close : t -> unit = \"ocaml_guestfs_create\" +external close : t -> unit = \"ocaml_guestfs_close\" + +let () = + Callback.register_exception \"ocaml_guestfs_error\" (Error \"\") "; + generate_ocaml_lvm_structure_decls (); (* The actions. *) @@ -1672,8 +1683,7 @@ and generate_ocaml_c () = pr "#include \n"; pr "#include \n"; - pr "\n"; - pr "#include \n"; + pr "#include \n"; pr "\n"; pr "#include \n"; pr "#include \n"; @@ -1681,18 +1691,164 @@ and generate_ocaml_c () = pr "#include \n"; pr "#include \n"; pr "#include \n"; + pr "#include \n"; + pr "\n"; + pr "#include \n"; pr "\n"; pr "#include \"guestfs_c.h\"\n"; pr "\n"; + (* LVM struct copy functions. *) + List.iter ( + fun (typ, cols) -> + let has_optpercent_col = + List.exists (function (_, `OptPercent) -> true | _ -> false) cols in + + pr "static CAMLprim value\n"; + pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ; + pr "{\n"; + pr " CAMLparam0 ();\n"; + if has_optpercent_col then + pr " CAMLlocal3 (rv, v, v2);\n" + else + pr " CAMLlocal2 (rv, v);\n"; + pr "\n"; + pr " rv = caml_alloc (%d, 0);\n" (List.length cols); + iteri ( + fun i col -> + (match col with + | name, `String -> + pr " v = caml_copy_string (%s->%s);\n" typ name + | name, `UUID -> + pr " v = caml_alloc_string (32);\n"; + pr " memcpy (String_val (v), %s->%s, 32);\n" typ name + | name, `Bytes + | name, `Int -> + pr " v = caml_copy_int64 (%s->%s);\n" typ name + | name, `OptPercent -> + pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name; + pr " v2 = caml_copy_double (%s->%s);\n" typ name; + pr " v = caml_alloc (1, 0);\n"; + pr " Store_field (v, 0, v2);\n"; + pr " } else /* None */\n"; + pr " v = Val_int (0);\n"; + ); + pr " Store_field (rv, %d, v);\n" i + ) cols; + pr " CAMLreturn (rv);\n"; + pr "}\n"; + pr "\n"; + + pr "static CAMLprim value\n"; + pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n" + typ typ typ; + pr "{\n"; + pr " CAMLparam0 ();\n"; + pr " CAMLlocal2 (rv, v);\n"; + pr " int i;\n"; + pr "\n"; + pr " if (%ss->len == 0)\n" typ; + pr " CAMLreturn (Atom (0));\n"; + pr " else {\n"; + pr " rv = caml_alloc (%ss->len, 0);\n" typ; + pr " for (i = 0; i < %ss->len; ++i) {\n" typ; + pr " v = copy_lvm_%s (&%ss->val[i]);\n" typ typ; + pr " caml_modify (&Field (rv, i), v);\n"; + pr " }\n"; + pr " CAMLreturn (rv);\n"; + pr " }\n"; + pr "}\n"; + pr "\n"; + ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]; + List.iter ( fun (name, style, _, _, _, _) -> pr "CAMLprim value\n"; - pr "ocaml_guestfs_%s (value hv /* XXX */)\n" name; + pr "ocaml_guestfs_%s (value gv" name; + iter_args ( + function + | String n | OptString n | Bool n -> pr ", value %sv" n + ) (snd style); + pr ")\n"; pr "{\n"; - pr " CAMLparam1 (hv); /* XXX */\n"; - pr "/* XXX write something here */\n"; - pr " CAMLreturn (Val_unit); /* XXX */\n"; + pr " CAMLparam%d (gv" (1 + (nr_args (snd style))); + iter_args ( + function + | String n | OptString n | Bool n -> pr ", %sv" n + ) (snd style); + pr ");\n"; + pr " CAMLlocal1 (rv);\n"; + pr "\n"; + + pr " guestfs_h *g = Guestfs_val (gv);\n"; + pr " if (g == NULL)\n"; + pr " caml_failwith (\"%s: used handle after closing it\");\n" name; + pr "\n"; + + iter_args ( + function + | String n -> + pr " const char *%s = String_val (%sv);\n" n n + | OptString n -> + pr " const char *%s =\n" n; + pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n" + n n + | Bool n -> + pr " int %s = Bool_val (%sv);\n" n n + ) (snd style); + let error_code = + match fst style with + | Err -> pr " int r;\n"; "-1" + | RBool _ -> pr " int r;\n"; "-1" + | RConstString _ -> pr " const char *r;\n"; "NULL" + | RString _ -> pr " char *r;\n"; "NULL" + | RStringList _ -> + pr " int i;\n"; + pr " char **r;\n"; + "NULL" + | RPVList _ -> + pr " struct guestfs_lvm_pv_list *r;\n"; + "NULL" + | RVGList _ -> + pr " struct guestfs_lvm_vg_list *r;\n"; + "NULL" + | RLVList _ -> + pr " struct guestfs_lvm_lv_list *r;\n"; + "NULL" in + pr "\n"; + + pr " caml_enter_blocking_section ();\n"; + pr " r = guestfs_%s " name; + generate_call_args ~handle:"g" style; + pr ";\n"; + pr " caml_leave_blocking_section ();\n"; + pr " if (r == %s)\n" error_code; + pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name; + pr "\n"; + + (match fst style with + | Err -> pr " rv = Val_unit;\n" + | RBool _ -> pr " rv = r ? Val_true : Val_false;\n" + | RConstString _ -> pr " rv = caml_copy_string (r);\n" + | RString _ -> + pr " rv = caml_copy_string (r);\n"; + pr " free (r);\n" + | RStringList _ -> + pr " rv = caml_copy_string_array ((const char **) r);\n"; + pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n"; + pr " free (r);\n" + | RPVList _ -> + pr " rv = copy_lvm_pv_list (r);\n"; + pr " guestfs_free_lvm_pv_list (r);\n"; + | RVGList _ -> + pr " rv = copy_lvm_vg_list (r);\n"; + pr " guestfs_free_lvm_vg_list (r);\n"; + | RLVList _ -> + pr " rv = copy_lvm_lv_list (r);\n"; + pr " guestfs_free_lvm_lv_list (r);\n"; + ); + + pr " CAMLreturn (rv);\n"; pr "}\n"; pr "\n" ) all_functions @@ -1727,10 +1883,10 @@ and generate_ocaml_prototype ?(is_external = false) name style = | RBool _ -> pr "bool" | RConstString _ -> pr "string" | RString _ -> pr "string" - | RStringList _ -> pr "string list" - | RPVList _ -> pr "lvm_pv list" - | RVGList _ -> pr "lvm_vg list" - | RLVList _ -> pr "lvm_lv list" + | RStringList _ -> pr "string array" + | RPVList _ -> pr "lvm_pv array" + | RVGList _ -> pr "lvm_vg array" + | RLVList _ -> pr "lvm_lv array" ); if is_external then pr " = \"ocaml_guestfs_%s\"" name; pr "\n"