/* OCaml bindings for libvirt.
- * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ * (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
* http://libvirt.org/
*
* This library is free software; you can redistribute it and/or
typeVer_ptr = driver ? &typeVer : NULL;
NONBLOCKING (r = virGetVersion (&libVer, driver, typeVer_ptr));
- CHECK_ERROR (r == -1, NULL, "virGetVersion");
+ CHECK_ERROR (r == -1, "virGetVersion");
rv = caml_alloc_tuple (2);
Store_field (rv, 0, Val_int (libVer));
virConnectPtr conn;
NONBLOCKING (conn = virConnectOpen (name));
- CHECK_ERROR (!conn, NULL, "virConnectOpen");
+ CHECK_ERROR (!conn, "virConnectOpen");
rv = Val_connect (conn);
virConnectPtr conn;
NONBLOCKING (conn = virConnectOpenReadOnly (name));
- CHECK_ERROR (!conn, NULL, "virConnectOpen");
+ CHECK_ERROR (!conn, "virConnectOpen");
rv = Val_connect (conn);
CAMLreturn (rv);
}
+/* Helper struct holding data needed for the helper C authentication
+ * callback (which will call the actual OCaml callback).
+ */
+struct ocaml_auth_callback_data {
+ value *fvp; /* The OCaml auth callback. */
+};
+
+static int
+_ocaml_auth_callback (virConnectCredentialPtr cred, unsigned int ncred, void *cbdata)
+{
+ CAMLparam0 ();
+ CAMLlocal4 (listv, elemv, rv, v);
+ struct ocaml_auth_callback_data *s = cbdata;
+ int i, len;
+
+ listv = Val_emptylist;
+ for (i = ncred - 1; i >= 0; --i) {
+ elemv = caml_alloc (2, 0);
+ Store_field (elemv, 0, Val_virconnectcredential (&cred[i]));
+ Store_field (elemv, 1, listv);
+ listv = elemv;
+ }
+
+ /* Call the auth callback. */
+ rv = caml_callback_exn (*s->fvp, listv);
+ if (Is_exception_result (rv)) {
+ /* The callback raised an exception, so return an error. */
+ CAMLreturnT (int, -1);
+ }
+
+ len = _list_length (rv);
+ if (len != (int) ncred) {
+ /* The callback did not return the same number of results as the
+ * credentials.
+ */
+ CAMLreturnT (int, -1);
+ }
+
+ for (i = 0; rv != Val_emptylist; rv = Field (rv, 1), ++i) {
+ virConnectCredentialPtr c = &cred[i];
+ elemv = Field (rv, 0);
+ if (elemv == Val_int (0)) {
+ c->result = NULL;
+ c->resultlen = 0;
+ } else {
+ v = Field (elemv, 0);
+ len = caml_string_length (v);
+ c->result = malloc (len + 1);
+ if (c->result == NULL)
+ CAMLreturnT (int, -1);
+ memcpy (c->result, String_val (v), len);
+ c->result[len] = '\0';
+ c->resultlen = len;
+ }
+ }
+
+ CAMLreturnT (int, 0);
+}
+
+static virConnectPtr
+_ocaml_libvirt_connect_open_auth_common (value namev, value authv, int flags)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal2 (listv, fv);
+ virConnectPtr conn;
+ virConnectAuth auth;
+ struct ocaml_auth_callback_data data;
+ int i;
+ char *name = NULL;
+
+ /* Keep a copy of the 'namev' string, as its value could move around
+ * when calling other OCaml code that allocates memory.
+ */
+ if (namev != Val_int (0)) { /* Some string */
+ name = strdup (String_val (Field (namev, 0)));
+ if (name == NULL)
+ caml_raise_out_of_memory ();
+ }
+
+ fv = Field (authv, 1);
+ data.fvp = &fv;
+
+ listv = Field (authv, 0);
+ auth.ncredtype = _list_length (listv);
+ auth.credtype = malloc (sizeof (int) * auth.ncredtype);
+ if (auth.credtype == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
+ auth.credtype[i] = Int_val (Field (listv, 0)) + 1;
+ }
+ auth.cb = &_ocaml_auth_callback;
+ auth.cbdata = &data;
+
+ /* Call virConnectOpenAuth directly, without using the NONBLOCKING
+ * macro, as this will indeed call ocaml_* APIs, and run OCaml code.
+ */
+ conn = virConnectOpenAuth (name, &auth, flags);
+ free (auth.credtype);
+ free (name);
+ CHECK_ERROR (!conn, "virConnectOpenAuth");
+
+ CAMLreturnT (virConnectPtr, conn);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, 0);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_open_auth_readonly (value namev, value authv)
+{
+ CAMLparam2 (namev, authv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn;
+
+ conn = _ocaml_libvirt_connect_open_auth_common (namev, authv, VIR_CONNECT_RO);
+ rv = Val_connect (conn);
+
+ CAMLreturn (rv);
+}
+
CAMLprim value
ocaml_libvirt_connect_get_version (value connv)
{
int r;
NONBLOCKING (r = virConnectGetVersion (conn, &hvVer));
- CHECK_ERROR (r == -1, conn, "virConnectGetVersion");
+ CHECK_ERROR (r == -1, "virConnectGetVersion");
CAMLreturn (Val_int (hvVer));
}
int r;
NONBLOCKING (r = virConnectGetMaxVcpus (conn, type));
- CHECK_ERROR (r == -1, conn, "virConnectGetMaxVcpus");
+ CHECK_ERROR (r == -1, "virConnectGetMaxVcpus");
CAMLreturn (Val_int (r));
}
int r;
NONBLOCKING (r = virNodeGetInfo (conn, &info));
- CHECK_ERROR (r == -1, conn, "virNodeGetInfo");
+ CHECK_ERROR (r == -1, "virNodeGetInfo");
rv = caml_alloc (8, 0);
v = caml_copy_string (info.model); Store_field (rv, 0, v);
unsigned long long r;
NONBLOCKING (r = virNodeGetFreeMemory (conn));
- CHECK_ERROR (r == 0, conn, "virNodeGetFreeMemory");
+ CHECK_ERROR (r == 0, "virNodeGetFreeMemory");
- rv = caml_copy_int64 ((int64) r);
+ rv = caml_copy_int64 ((int64_t) r);
CAMLreturn (rv);
}
int start = Int_val (startv);
int max = Int_val (maxv);
int r, i;
- unsigned long long freemems[max];
+ unsigned long long *freemems;
+
+ freemems = malloc(sizeof (*freemems) * max);
+ if (freemems == NULL)
+ caml_raise_out_of_memory ();
NONBLOCKING (r = virNodeGetCellsFreeMemory (conn, freemems, start, max));
- CHECK_ERROR (r == -1, conn, "virNodeGetCellsFreeMemory");
+ CHECK_ERROR_CLEANUP (r == -1, free (freemems), "virNodeGetCellsFreeMemory");
rv = caml_alloc (r, 0);
for (i = 0; i < r; ++i) {
- iv = caml_copy_int64 ((int64) freemems[i]);
+ iv = caml_copy_int64 ((int64_t) freemems[i]);
Store_field (rv, i, iv);
}
+ free (freemems);
CAMLreturn (rv);
}
int r;
NONBLOCKING(r = virConnectSetKeepAlive(conn, interval, count));
- CHECK_ERROR (r == -1, conn, "virConnectSetKeepAlive");
+ CHECK_ERROR (r == -1, "virConnectSetKeepAlive");
CAMLreturn(Val_unit);
}
-
CAMLprim value
ocaml_libvirt_domain_get_id (value domv)
{
CAMLparam1 (domv);
virDomainPtr dom = Domain_val (domv);
- /*virConnectPtr conn = Connect_domv (domv);*/
unsigned int r;
NONBLOCKING (r = virDomainGetID (dom));
CAMLparam1 (domv);
CAMLlocal1 (rv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
unsigned long r;
NONBLOCKING (r = virDomainGetMaxMemory (dom));
- CHECK_ERROR (r == 0 /* [sic] */, conn, "virDomainGetMaxMemory");
+ CHECK_ERROR (r == 0 /* [sic] */, "virDomainGetMaxMemory");
rv = caml_copy_int64 (r);
CAMLreturn (rv);
{
CAMLparam2 (domv, memv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
unsigned long mem = Int64_val (memv);
int r;
NONBLOCKING (r = virDomainSetMaxMemory (dom, mem));
- CHECK_ERROR (r == -1, conn, "virDomainSetMaxMemory");
+ CHECK_ERROR (r == -1, "virDomainSetMaxMemory");
CAMLreturn (Val_unit);
}
{
CAMLparam2 (domv, memv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
unsigned long mem = Int64_val (memv);
int r;
NONBLOCKING (r = virDomainSetMemory (dom, mem));
- CHECK_ERROR (r == -1, conn, "virDomainSetMemory");
+ CHECK_ERROR (r == -1, "virDomainSetMemory");
CAMLreturn (Val_unit);
}
CAMLparam1 (domv);
CAMLlocal2 (rv, v);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
virDomainInfo info;
int r;
NONBLOCKING (r = virDomainGetInfo (dom, &info));
- CHECK_ERROR (r == -1, conn, "virDomainGetInfo");
+ CHECK_ERROR (r == -1, "virDomainGetInfo");
rv = caml_alloc (5, 0);
Store_field (rv, 0, Val_int (info.state)); // These flags are compatible.
CAMLparam1 (domv);
CAMLlocal2 (rv, strv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
char *r;
int nparams;
NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams));
- CHECK_ERROR (!r, conn, "virDomainGetSchedulerType");
+ CHECK_ERROR (!r, "virDomainGetSchedulerType");
rv = caml_alloc_tuple (2);
strv = caml_copy_string (r); Store_field (rv, 0, strv);
CAMLparam2 (domv, nparamsv);
CAMLlocal4 (rv, v, v2, v3);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int nparams = Int_val (nparamsv);
- virSchedParameter params[nparams];
+ virSchedParameterPtr params;
int r, i;
+ params = malloc (sizeof (*params) * nparams);
+ if (params == NULL)
+ caml_raise_out_of_memory ();
+
NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params, &nparams));
- CHECK_ERROR (r == -1, conn, "virDomainGetSchedulerParameters");
+ CHECK_ERROR_CLEANUP (r == -1, free (params), "virDomainGetSchedulerParameters");
rv = caml_alloc (nparams, 0);
for (i = 0; i < nparams; ++i) {
}
Store_field (v, 1, v2);
}
+ free (params);
CAMLreturn (rv);
}
CAMLparam2 (domv, paramsv);
CAMLlocal1 (v);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int nparams = Wosize_val (paramsv);
- virSchedParameter params[nparams];
+ virSchedParameterPtr params;
int r, i;
char *name;
+ params = malloc (sizeof (*params) * nparams);
+ if (params == NULL)
+ caml_raise_out_of_memory ();
+
for (i = 0; i < nparams; ++i) {
v = Field (paramsv, i); /* Points to the two-element tuple. */
name = String_val (Field (v, 0));
}
NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams));
- CHECK_ERROR (r == -1, conn, "virDomainSetSchedulerParameters");
+ free (params);
+ CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters");
CAMLreturn (Val_unit);
}
{
CAMLparam2 (domv, nvcpusv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int r, nvcpus = Int_val (nvcpusv);
NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus));
- CHECK_ERROR (r == -1, conn, "virDomainSetVcpus");
+ CHECK_ERROR (r == -1, "virDomainSetVcpus");
CAMLreturn (Val_unit);
}
{
CAMLparam3 (domv, vcpuv, cpumapv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int maplen = caml_string_length (cpumapv);
unsigned char *cpumap = (unsigned char *) String_val (cpumapv);
int vcpu = Int_val (vcpuv);
int r;
NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen));
- CHECK_ERROR (r == -1, conn, "virDomainPinVcpu");
+ CHECK_ERROR (r == -1, "virDomainPinVcpu");
CAMLreturn (Val_unit);
}
CAMLparam3 (domv, maxinfov, maplenv);
CAMLlocal5 (rv, infov, strv, v, v2);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int maxinfo = Int_val (maxinfov);
int maplen = Int_val (maplenv);
- virVcpuInfo info[maxinfo];
- unsigned char cpumaps[maxinfo * maplen];
+ virVcpuInfoPtr info;
+ unsigned char *cpumaps;
int r, i;
- memset (info, 0, sizeof (virVcpuInfo) * maxinfo);
- memset (cpumaps, 0, maxinfo * maplen);
+ info = calloc (maxinfo, sizeof (*info));
+ if (info == NULL)
+ caml_raise_out_of_memory ();
+ cpumaps = calloc (maxinfo * maplen, sizeof (*cpumaps));
+ if (cpumaps == NULL) {
+ free (info);
+ caml_raise_out_of_memory ();
+ }
NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen));
- CHECK_ERROR (r == -1, conn, "virDomainPinVcpu");
+ CHECK_ERROR_CLEANUP (r == -1, free (info); free (cpumaps), "virDomainPinVcpu");
/* Copy the virVcpuInfo structures. */
infov = caml_alloc (maxinfo, 0);
Store_field (rv, 1, infov);
Store_field (rv, 2, strv);
+ free (info);
+ free (cpumaps);
+
CAMLreturn (rv);
}
CAMLlocal5 (cpustats, param_head, param_node, typed_param, typed_param_value);
CAMLlocal1 (v);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
virTypedParameterPtr params;
int r, cpu, ncpus, nparams, i, j, pos;
int nr_pcpus;
/* get number of pcpus */
NONBLOCKING (nr_pcpus = virDomainGetCPUStats(dom, NULL, 0, 0, 0, 0));
- CHECK_ERROR (nr_pcpus < 0, conn, "virDomainGetCPUStats");
+ CHECK_ERROR (nr_pcpus < 0, "virDomainGetCPUStats");
/* get percpu information */
NONBLOCKING (nparams = virDomainGetCPUStats(dom, NULL, 0, 0, 1, 0));
- CHECK_ERROR (nparams < 0, conn, "virDomainGetCPUStats");
+ CHECK_ERROR (nparams < 0, "virDomainGetCPUStats");
if ((params = malloc(sizeof(*params) * nparams * 128)) == NULL)
caml_failwith ("virDomainGetCPUStats: malloc");
ncpus = nr_pcpus - cpu > 128 ? 128 : nr_pcpus - cpu;
NONBLOCKING (r = virDomainGetCPUStats(dom, params, nparams, cpu, ncpus, 0));
- CHECK_ERROR (r < 0, conn, "virDomainGetCPUStats");
+ CHECK_ERROR (r < 0, "virDomainGetCPUStats");
for (i = 0; i < ncpus; i++) {
/* list of typed_param: single linked list of param_nodes */
CAMLreturn (cpustats);
}
+value
+ocaml_libvirt_domain_get_all_domain_stats (value connv,
+ value statsv, value flagsv)
+{
+ CAMLparam3 (connv, statsv, flagsv);
+ CAMLlocal5 (rv, dsv, tpv, v, v1);
+ CAMLlocal1 (v2);
+ virConnectPtr conn = Connect_val (connv);
+ virDomainStatsRecordPtr *rstats;
+ unsigned int stats = 0, flags = 0;
+ int i, j, r;
+ unsigned char uuid[VIR_UUID_BUFLEN];
+
+ /* Get stats and flags. */
+ for (; statsv != Val_int (0); statsv = Field (statsv, 1)) {
+ v = Field (statsv, 0);
+ if (v == Val_int (0))
+ stats |= VIR_DOMAIN_STATS_STATE;
+ else if (v == Val_int (1))
+ stats |= VIR_DOMAIN_STATS_CPU_TOTAL;
+ else if (v == Val_int (2))
+ stats |= VIR_DOMAIN_STATS_BALLOON;
+ else if (v == Val_int (3))
+ stats |= VIR_DOMAIN_STATS_VCPU;
+ else if (v == Val_int (4))
+ stats |= VIR_DOMAIN_STATS_INTERFACE;
+ else if (v == Val_int (5))
+ stats |= VIR_DOMAIN_STATS_BLOCK;
+ else if (v == Val_int (6))
+ stats |= VIR_DOMAIN_STATS_PERF;
+ }
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) {
+ v = Field (flagsv, 0);
+ if (v == Val_int (0))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ACTIVE;
+ else if (v == Val_int (1))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_INACTIVE;
+ else if (v == Val_int (2))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_OTHER;
+ else if (v == Val_int (3))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PAUSED;
+ else if (v == Val_int (4))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_PERSISTENT;
+ else if (v == Val_int (5))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_RUNNING;
+ else if (v == Val_int (6))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_SHUTOFF;
+ else if (v == Val_int (7))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_TRANSIENT;
+ else if (v == Val_int (8))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_BACKING;
+ else if (v == Val_int (9))
+ flags |= VIR_CONNECT_GET_ALL_DOMAINS_STATS_ENFORCE_STATS;
+ }
+
+ NONBLOCKING (r = virConnectGetAllDomainStats (conn, stats, &rstats, flags));
+ CHECK_ERROR (r == -1, "virConnectGetAllDomainStats");
+
+ rv = caml_alloc (r, 0); /* domain_stats_record array. */
+ for (i = 0; i < r; ++i) {
+ dsv = caml_alloc (2, 0); /* domain_stats_record */
+
+ /* Libvirt returns something superficially resembling a
+ * virDomainPtr, but it's not a real virDomainPtr object
+ * (eg. dom->id == -1, and its refcount is wrong). The only thing
+ * we can safely get from it is the UUID.
+ */
+ v = caml_alloc_string (VIR_UUID_BUFLEN);
+ virDomainGetUUID (rstats[i]->dom, uuid);
+ memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
+ Store_field (dsv, 0, v);
+
+ tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
+ for (j = 0; j < rstats[i]->nparams; ++j) {
+ v2 = caml_alloc (2, 0); /* typed_param: field name, value */
+ Store_field (v2, 0, caml_copy_string (rstats[i]->params[j].field));
+
+ switch (rstats[i]->params[j].type) {
+ case VIR_TYPED_PARAM_INT:
+ v1 = caml_alloc (1, 0);
+ v = caml_copy_int32 (rstats[i]->params[j].value.i);
+ break;
+ case VIR_TYPED_PARAM_UINT:
+ v1 = caml_alloc (1, 1);
+ v = caml_copy_int32 (rstats[i]->params[j].value.ui);
+ break;
+ case VIR_TYPED_PARAM_LLONG:
+ v1 = caml_alloc (1, 2);
+ v = caml_copy_int64 (rstats[i]->params[j].value.l);
+ break;
+ case VIR_TYPED_PARAM_ULLONG:
+ v1 = caml_alloc (1, 3);
+ v = caml_copy_int64 (rstats[i]->params[j].value.ul);
+ break;
+ case VIR_TYPED_PARAM_DOUBLE:
+ v1 = caml_alloc (1, 4);
+ v = caml_copy_double (rstats[i]->params[j].value.d);
+ break;
+ case VIR_TYPED_PARAM_BOOLEAN:
+ v1 = caml_alloc (1, 5);
+ v = Val_bool (rstats[i]->params[j].value.b);
+ break;
+ case VIR_TYPED_PARAM_STRING:
+ v1 = caml_alloc (1, 6);
+ v = caml_copy_string (rstats[i]->params[j].value.s);
+ break;
+ default:
+ virDomainStatsRecordListFree (rstats);
+ caml_failwith ("virConnectGetAllDomainStats: "
+ "unknown parameter type returned");
+ }
+ Store_field (v1, 0, v);
+
+ Store_field (v2, 1, v1);
+ Store_field (tpv, j, v2);
+ }
+
+ Store_field (dsv, 1, tpv);
+ Store_field (rv, i, dsv);
+ }
+
+ virDomainStatsRecordListFree (rstats);
+ CAMLreturn (rv);
+}
+
CAMLprim value
ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv)
{
CAMLxparam2 (optbandwidthv, unitv);
CAMLlocal2 (flagv, rv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
virConnectPtr dconn = Connect_val (dconnv);
int flags = 0;
const char *dname = Optstring_val (optdnamev);
bandwidth = Int_val (Field (optbandwidthv, 0));
NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri, bandwidth));
- CHECK_ERROR (!r, conn, "virDomainMigrate");
+ CHECK_ERROR (!r, "virDomainMigrate");
rv = Val_domain (r, dconnv);
CAMLparam2 (domv, pathv);
CAMLlocal2 (rv,v);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
char *path = String_val (pathv);
struct _virDomainBlockStats stats;
int r;
NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats));
- CHECK_ERROR (r == -1, conn, "virDomainBlockStats");
+ CHECK_ERROR (r == -1, "virDomainBlockStats");
rv = caml_alloc (5, 0);
v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v);
CAMLparam2 (domv, pathv);
CAMLlocal2 (rv,v);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
char *path = String_val (pathv);
struct _virDomainInterfaceStats stats;
int r;
NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof stats));
- CHECK_ERROR (r == -1, conn, "virDomainInterfaceStats");
+ CHECK_ERROR (r == -1, "virDomainInterfaceStats");
rv = caml_alloc (8, 0);
v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v);
CAMLparam5 (domv, pathv, offsetv, sizev, bufferv);
CAMLxparam1 (boffv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
const char *path = String_val (pathv);
unsigned long long offset = Int64_val (offsetv);
size_t size = Int_val (sizev);
/* NB. not NONBLOCKING because buffer might move (XXX) */
r = virDomainBlockPeek (dom, path, offset, size, buffer+boff, 0);
- CHECK_ERROR (r == -1, conn, "virDomainBlockPeek");
+ CHECK_ERROR (r == -1, "virDomainBlockPeek");
CAMLreturn (Val_unit);
}
CAMLxparam1 (boffv);
CAMLlocal1 (flagv);
virDomainPtr dom = Domain_val (domv);
- virConnectPtr conn = Connect_domv (domv);
int flags = 0;
unsigned long long offset = Int64_val (offsetv);
size_t size = Int_val (sizev);
/* NB. not NONBLOCKING because buffer might move (XXX) */
r = virDomainMemoryPeek (dom, offset, size, buffer+boff, flags);
- CHECK_ERROR (r == -1, conn, "virDomainMemoryPeek");
+ CHECK_ERROR (r == -1, "virDomainMemoryPeek");
CAMLreturn (Val_unit);
}
}
CAMLprim value
+ocaml_libvirt_domain_get_xml_desc_flags (value domv, value flagsv)
+{
+ CAMLparam2 (domv, flagsv);
+ CAMLlocal2 (rv, flagv);
+ virDomainPtr dom = Domain_val (domv);
+ int flags = 0;
+ char *r;
+
+ /* Do flags. */
+ for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1))
+ {
+ flagv = Field (flagsv, 0);
+ if (flagv == Val_int (0))
+ flags |= VIR_DOMAIN_XML_SECURE;
+ else if (flagv == Val_int (1))
+ flags |= VIR_DOMAIN_XML_INACTIVE;
+ else if (flagv == Val_int (2))
+ flags |= VIR_DOMAIN_XML_UPDATE_CPU;
+ else if (flagv == Val_int (3))
+ flags |= VIR_DOMAIN_XML_MIGRATABLE;
+ }
+
+ NONBLOCKING (r = virDomainGetXMLDesc (dom, flags));
+ CHECK_ERROR (!r, "virDomainGetXMLDesc");
+
+ rv = caml_copy_string (r);
+ free (r);
+ CAMLreturn (rv);
+}
+
+/*----------------------------------------------------------------------*/
+
+/* Domain events */
+
+CAMLprim value
+ocaml_libvirt_event_register_default_impl (value unitv)
+{
+ CAMLparam1 (unitv);
+
+ /* arg is of type unit = void */
+ int r;
+
+ NONBLOCKING (r = virEventRegisterDefaultImpl ());
+ /* must be called before connection, therefore we can't use CHECK_ERROR */
+ if (r == -1) caml_failwith("virEventRegisterDefaultImpl");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_event_run_default_impl (value unitv)
+{
+ CAMLparam1 (unitv);
+
+ /* arg is of type unit = void */
+ int r;
+
+ NONBLOCKING (r = virEventRunDefaultImpl ());
+ if (r == -1) caml_failwith("virEventRunDefaultImpl");
+
+ CAMLreturn (Val_unit);
+}
+
+/* We register a single C callback function for every distinct
+ callback signature. We encode the signature itself in the function
+ name and also in the name of the assocated OCaml callback
+ e.g.:
+ a C function called
+ i_i64_s_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ long y,
+ char *z,
+ void *opaque)
+ would correspond to an OCaml callback
+ Libvirt.i_i64_s_callback :
+ int64 -> [`R] Domain.t -> int -> int64 -> string option -> unit
+ where the initial int64 is a unique ID used by the OCaml to
+ dispatch to the specific OCaml closure and stored by libvirt
+ as the "opaque" data. */
+
+/* Every one of the callbacks starts with a DOMAIN_CALLBACK_BEGIN(NAME)
+ where NAME is the string name of the OCaml callback registered
+ in libvirt.ml. */
+#define DOMAIN_CALLBACK_BEGIN(NAME) \
+ value connv, domv, callback_id, result; \
+ connv = domv = callback_id = result = Val_int(0); \
+ static value *callback = NULL; \
+ caml_leave_blocking_section(); \
+ if (callback == NULL) \
+ callback = caml_named_value(NAME); \
+ if (callback == NULL) \
+ abort(); /* C code out of sync with OCaml code */ \
+ if ((virDomainRef(dom) == -1) || (virConnectRef(conn) == -1)) \
+ abort(); /* should never happen in practice? */ \
+ \
+ Begin_roots4(connv, domv, callback_id, result); \
+ connv = Val_connect(conn); \
+ domv = Val_domain(dom, connv); \
+ callback_id = caml_copy_int64(*(long *)opaque);
+
+/* Every one of the callbacks ends with a CALLBACK_END */
+#define DOMAIN_CALLBACK_END \
+ (void) caml_callback3(*callback, callback_id, domv, result); \
+ End_roots(); \
+ caml_enter_blocking_section();
+
+
+static void
+i_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ int y,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_i_callback")
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0, Val_int(x));
+ Store_field(result, 1, Val_int(y));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+u_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.u_callback")
+ result = Val_int(0); /* () */
+ DOMAIN_CALLBACK_END
+}
+
+static void
+i64_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ long long int64,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i64_callback")
+ result = caml_copy_int64(int64);
+ DOMAIN_CALLBACK_END
+}
+
+static void
+i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int x,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_callback")
+ result = Val_int(x);
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ int y,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_callback")
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1, Val_int(y));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_i_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ int y,
+ int z,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_i_i_callback")
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1, Val_int(y));
+ Store_field(result, 2, Val_int(z));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ char *y,
+ int z,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_callback")
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2, Val_int(z));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_i_s_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char *x,
+ char *y,
+ int z,
+ char *a,
+ void *opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_i_s_callback")
+ result = caml_alloc_tuple(4);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2, Val_int(z));
+ Store_field(result, 3,
+ Val_opt(a, (Val_ptr_t) caml_copy_string));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+s_s_s_i_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ char * x,
+ char * y,
+ char * z,
+ int a,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.s_s_s_i_callback")
+ result = caml_alloc_tuple(4);
+ Store_field(result, 0,
+ Val_opt(x, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt(y, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2,
+ Val_opt(z, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 3, Val_int(a));
+ DOMAIN_CALLBACK_END
+}
+
+static value
+Val_event_graphics_address(virDomainEventGraphicsAddressPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ result = caml_alloc_tuple(3);
+ Store_field(result, 0, Val_int(x->family));
+ Store_field(result, 1,
+ Val_opt((void *) x->node, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 2,
+ Val_opt((void *) x->service, (Val_ptr_t) caml_copy_string));
+ CAMLreturn(result);
+}
+
+static value
+Val_event_graphics_subject_identity(virDomainEventGraphicsSubjectIdentityPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ result = caml_alloc_tuple(2);
+ Store_field(result, 0,
+ Val_opt((void *) x->type, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 1,
+ Val_opt((void *) x->name, (Val_ptr_t) caml_copy_string));
+ CAMLreturn(result);
+
+}
+
+static value
+Val_event_graphics_subject(virDomainEventGraphicsSubjectPtr x)
+{
+ CAMLparam0 ();
+ CAMLlocal1(result);
+ int i;
+ result = caml_alloc_tuple(x->nidentity);
+ for (i = 0; i < x->nidentity; i++ )
+ Store_field(result, i,
+ Val_event_graphics_subject_identity(x->identities + i));
+ CAMLreturn(result);
+}
+
+static void
+i_ga_ga_s_gs_callback(virConnectPtr conn,
+ virDomainPtr dom,
+ int i1,
+ virDomainEventGraphicsAddressPtr ga1,
+ virDomainEventGraphicsAddressPtr ga2,
+ char *s1,
+ virDomainEventGraphicsSubjectPtr gs1,
+ void * opaque)
+{
+ DOMAIN_CALLBACK_BEGIN("Libvirt.i_ga_ga_s_gs_callback")
+ result = caml_alloc_tuple(5);
+ Store_field(result, 0, Val_int(i1));
+ Store_field(result, 1, Val_event_graphics_address(ga1));
+ Store_field(result, 2, Val_event_graphics_address(ga2));
+ Store_field(result, 3,
+ Val_opt(s1, (Val_ptr_t) caml_copy_string));
+ Store_field(result, 4, Val_event_graphics_subject(gs1));
+ DOMAIN_CALLBACK_END
+}
+
+static void
+timeout_callback(int timer, void *opaque)
+{
+ value callback_id, result;
+ callback_id = result = Val_int(0);
+ static value *callback = NULL;
+ caml_leave_blocking_section();
+ if (callback == NULL)
+ callback = caml_named_value("Libvirt.timeout_callback");
+ if (callback == NULL)
+ abort(); /* C code out of sync with OCaml code */
+
+ Begin_roots2(callback_id, result);
+ callback_id = caml_copy_int64(*(long *)opaque);
+
+ (void)caml_callback_exn(*callback, callback_id);
+ End_roots();
+ caml_enter_blocking_section();
+}
+
+CAMLprim value
+ocaml_libvirt_event_add_timeout (value connv, value ms, value callback_id)
+{
+ CAMLparam3 (connv, ms, callback_id);
+ void *opaque;
+ virFreeCallback freecb = free;
+ virEventTimeoutCallback cb = timeout_callback;
+
+ int r;
+
+ /* Store the int64 callback_id as the opaque data so the OCaml
+ callback can demultiplex to the correct OCaml handler. */
+ if ((opaque = malloc(sizeof(long))) == NULL)
+ caml_failwith ("virEventAddTimeout: malloc");
+ *((long*)opaque) = Int64_val(callback_id);
+ NONBLOCKING(r = virEventAddTimeout(Int_val(ms), cb, opaque, freecb));
+ CHECK_ERROR(r == -1, "virEventAddTimeout");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
+ocaml_libvirt_event_remove_timeout (value connv, value timer_id)
+{
+ CAMLparam2 (connv, timer_id);
+ int r;
+
+ NONBLOCKING(r = virEventRemoveTimeout(Int_val(timer_id)));
+ CHECK_ERROR(r == -1, "virEventRemoveTimeout");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_domain_event_register_any(value connv, value domv, value callback, value callback_id)
+{
+ CAMLparam4(connv, domv, callback, callback_id);
+
+ virConnectPtr conn = Connect_val (connv);
+ virDomainPtr dom = NULL;
+ int eventID = Tag_val(callback);
+
+ virConnectDomainEventGenericCallback cb;
+ void *opaque;
+ virFreeCallback freecb = free;
+ int r;
+
+ if (domv != Val_int(0))
+ dom = Domain_val (Field(domv, 0));
+
+ switch (eventID){
+ case VIR_DOMAIN_EVENT_ID_LIFECYCLE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_REBOOT:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_RTC_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_WATCHDOG:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_IO_ERROR:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_GRAPHICS:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_ga_ga_s_gs_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_IO_ERROR_REASON:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_i_s_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_CONTROL_ERROR:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(u_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_BLOCK_JOB:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_DISK_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_s_s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_TRAY_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(s_i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMWAKEUP:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMSUSPEND:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_BALLOON_CHANGE:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i64_callback);
+ break;
+ case VIR_DOMAIN_EVENT_ID_PMSUSPEND_DISK:
+ cb = VIR_DOMAIN_EVENT_CALLBACK(i_callback);
+ break;
+ default:
+ caml_failwith("vifConnectDomainEventRegisterAny: unimplemented eventID");
+ }
+
+ /* Store the int64 callback_id as the opaque data so the OCaml
+ callback can demultiplex to the correct OCaml handler. */
+ if ((opaque = malloc(sizeof(long))) == NULL)
+ caml_failwith ("virConnectDomainEventRegisterAny: malloc");
+ *((long*)opaque) = Int64_val(callback_id);
+ NONBLOCKING(r = virConnectDomainEventRegisterAny(conn, dom, eventID, cb, opaque, freecb));
+ CHECK_ERROR(r == -1, "virConnectDomainEventRegisterAny");
+
+ CAMLreturn(Val_int(r));
+}
+
+CAMLprim value
ocaml_libvirt_storage_pool_get_info (value poolv)
{
CAMLparam1 (poolv);
CAMLlocal2 (rv, v);
virStoragePoolPtr pool = Pool_val (poolv);
- virConnectPtr conn = Connect_polv (poolv);
virStoragePoolInfo info;
int r;
NONBLOCKING (r = virStoragePoolGetInfo (pool, &info));
- CHECK_ERROR (r == -1, conn, "virStoragePoolGetInfo");
+ CHECK_ERROR (r == -1, "virStoragePoolGetInfo");
rv = caml_alloc (4, 0);
Store_field (rv, 0, Val_int (info.state));
CAMLparam1 (volv);
CAMLlocal2 (rv, v);
virStorageVolPtr vol = Volume_val (volv);
- virConnectPtr conn = Connect_volv (volv);
virStorageVolInfo info;
int r;
NONBLOCKING (r = virStorageVolGetInfo (vol, &info));
- CHECK_ERROR (r == -1, conn, "virStorageVolGetInfo");
+ CHECK_ERROR (r == -1, "virStorageVolGetInfo");
rv = caml_alloc (3, 0);
Store_field (rv, 0, Val_int (info.type));
/*----------------------------------------------------------------------*/
+static void
+ignore_errors (void *user_data, virErrorPtr error)
+{
+ /* do nothing */
+}
+
/* Initialise the library. */
CAMLprim value
ocaml_libvirt_init (value unit)
{
CAMLparam1 (unit);
- CAMLlocal1 (rv);
- int r;
- r = virInitialize ();
- CHECK_ERROR (r == -1, NULL, "virInitialize");
+ virSetErrorFunc (NULL, ignore_errors);
+ virInitialize ();
CAMLreturn (Val_unit);
}
git.annexia.org / ocaml-libvirt.git / blobdiff