/* OCaml bindings for libvirt.
* (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
- * http://libvirt.org/
+ * https://libvirt.org/
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
/* Please read libvirt/README file. */
+#ifdef __GNUC__
+#pragma GCC diagnostic ignored "-Wmissing-prototypes"
+#endif
+
/*----------------------------------------------------------------------*/
CAMLprim value
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, "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_t) freemems[i]);
Store_field (rv, i, iv);
}
+ free (freemems);
CAMLreturn (rv);
}
}
CAMLprim value
+ocaml_libvirt_connect_credtypes_from_auth_default (value unitv)
+{
+ CAMLparam1 (unitv);
+ CAMLlocal2 (listv, itemv);
+ int i;
+
+ listv = Val_emptylist;
+
+ if (virConnectAuthPtrDefault) {
+ for (i = virConnectAuthPtrDefault->ncredtype; i >= 0; --i) {
+ const int type = virConnectAuthPtrDefault->credtype[i];
+ itemv = caml_alloc (2, 0);
+ Store_field (itemv, 0, Val_int (type - 1));
+ Store_field (itemv, 1, listv);
+ listv = itemv;
+ }
+ }
+
+ CAMLreturn (listv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_call_auth_default_callback (value listv)
+{
+ CAMLparam1 (listv);
+ CAMLlocal5 (credv, retv, elemv, optv, v);
+ int i, len, ret;
+ const char *str;
+ virConnectCredentialPtr creds;
+
+ if (virConnectAuthPtrDefault == NULL
+ || virConnectAuthPtrDefault->cb == NULL)
+ CAMLreturn (Val_unit);
+
+ len = _list_length (listv);
+ creds = calloc (len, sizeof (*creds));
+ if (creds == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; listv != Val_emptylist; listv = Field (listv, 1), ++i) {
+ virConnectCredentialPtr cred = &creds[i];
+ credv = Field (listv, 0);
+ cred->type = Int_val (Field (credv, 0)) + 1;
+ cred->prompt = strdup (String_val (Field (credv, 1)));
+ if (cred->prompt == NULL)
+ caml_raise_out_of_memory ();
+ str = Optstring_val (Field (credv, 2));
+ if (str) {
+ cred->challenge = strdup (str);
+ if (cred->challenge == NULL)
+ caml_raise_out_of_memory ();
+ }
+ str = Optstring_val (Field (credv, 3));
+ if (str) {
+ cred->defresult = strdup (str);
+ if (cred->defresult == NULL)
+ caml_raise_out_of_memory ();
+ }
+ }
+
+ ret = virConnectAuthPtrDefault->cb (creds, len,
+ virConnectAuthPtrDefault->cbdata);
+ if (ret >= 0) {
+ retv = Val_emptylist;
+ for (i = len - 1; i >= 0; --i) {
+ virConnectCredentialPtr cred = &creds[i];
+ elemv = caml_alloc (2, 0);
+ if (cred->result != NULL && cred->resultlen > 0) {
+ v = caml_alloc_string (cred->resultlen);
+ memcpy (String_val (v), cred->result, cred->resultlen);
+ optv = caml_alloc (1, 0);
+ Store_field (optv, 0, v);
+ } else
+ optv = Val_int (0);
+ Store_field (elemv, 0, optv);
+ Store_field (elemv, 1, retv);
+ retv = elemv;
+ }
+ }
+ for (i = 0; i < len; ++i) {
+ virConnectCredentialPtr cred = &creds[i];
+ /* Cast to char *, as the virConnectCredential structs we fill have
+ * const char * qualifiers.
+ */
+ free ((char *) cred->prompt);
+ free ((char *) cred->challenge);
+ free ((char *) cred->defresult);
+ }
+ free (creds);
+
+ if (ret < 0)
+ caml_failwith ("virConnectAuthPtrDefault callback failed");
+
+ CAMLreturn (retv);
+}
+
+CAMLprim value
ocaml_libvirt_domain_get_id (value domv)
{
CAMLparam1 (domv);
CAMLlocal4 (rv, v, v2, v3);
virDomainPtr dom = Domain_val (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, "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);
}
CAMLlocal1 (v);
virDomainPtr dom = Domain_val (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));
+ free (params);
CHECK_ERROR (r == -1, "virDomainSetSchedulerParameters");
CAMLreturn (Val_unit);
virDomainPtr dom = Domain_val (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, "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);
}
argv[3], argv[4], argv[5]);
}
+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 */
CAMLreturn (rv);
}
+CAMLprim value
+ocaml_libvirt_secret_lookup_by_usage (value connv, value usagetypev, value usageidv)
+{
+ CAMLparam3 (connv, usagetypev, usageidv);
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ int usageType = Int_val (usagetypev);
+ const char *usageID = String_val (usageidv);
+ virSecretPtr r;
+
+ NONBLOCKING (r = virSecretLookupByUsage (conn, usageType, usageID));
+ CHECK_ERROR (!r, "virSecretLookupByUsage");
+
+ rv = Val_secret (r, connv);
+
+ CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_secret_set_value (value secv, value vv)
+{
+ CAMLparam2 (secv, vv);
+ virSecretPtr sec = Secret_val (secv);
+ const unsigned char *secval = (unsigned char *) String_val (vv);
+ const size_t size = caml_string_length (vv);
+ int r;
+
+ NONBLOCKING (r = virSecretSetValue (sec, secval, size, 0));
+ CHECK_ERROR (r == -1, "virSecretSetValue");
+
+ CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_secret_get_value (value secv)
+{
+ CAMLparam1 (secv);
+ CAMLlocal1 (rv);
+ virSecretPtr sec = Secret_val (secv);
+ unsigned char *secval;
+ size_t size = 0;
+
+ NONBLOCKING (secval = virSecretGetValue (sec, &size, 0));
+ CHECK_ERROR (secval == NULL, "virSecretGetValue");
+
+ rv = caml_alloc_string (size);
+ memcpy (String_val (rv), secval, size);
+ free (secval);
+
+ CAMLreturn (rv);
+}
+
/*----------------------------------------------------------------------*/
CAMLprim value
git.annexia.org / ocaml-libvirt.git / blobdiff