packages/ocaml-libvirt
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

!4 update ocaml-libcirt to v0.6.1.5

Browse Source 
Merge pull request !4 from penelope/openEuler-22.03-LTS-Next
This commit is contained in:
openeuler-ci-bot 2022-01-22 02:28:13 +00:00 committed by Gitee
commit ab14a94e26
No known key found for this signature in database
GPG Key ID: 173E9B9CA92EEF8F
18 changed files with 308 additions and 2988 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

213
0001-Add-a-binding-for-virDomainCreateXML.patch
View File

@ -1,213 +0,0 @@
From 7483c7454538584a3dbe4582096f058e6e877df6 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Fri, 6 Mar 2015 15:35:46 +0000
Subject: [PATCH] Add a binding for virDomainCreateXML.
This is more modern than the ancient virDomainCreateLinux API,
and crucially allows you to pass flags such as AUTODESTROY.
---
configure.ac | 2 +-
libvirt/generator.pl | 23 +++++++++++++++++++++--
libvirt/libvirt.ml | 19 ++++++++++++++++++-
libvirt/libvirt.mli | 13 +++++++++++--
libvirt/libvirt_c.c | 25 ++++++++++++++++++++++++-
5 files changed, 75 insertions(+), 7 deletions(-)
diff --git a/configure.ac b/configure.ac
index b7544b4..a719fb3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,5 +1,5 @@
# ocaml-libvirt
-# Copyright (C) 2007-2008 Red Hat Inc., Richard W.M. Jones
+# Copyright (C) 2007-2015 Red Hat Inc., Richard W.M. Jones
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index 8229ad1..421592b 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -1,7 +1,7 @@
#!/usr/bin/perl -w
#
# OCaml bindings for libvirt.
-# (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+# (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
# http://libvirt.org/
#
# This library is free software; you can redistribute it and/or
@@ -63,6 +63,7 @@ my @functions = (
sig => "conn, int : unit" },
{ name => "virDomainCreateLinux", sig => "conn, string, 0U : dom" },
+ { name => "virDomainCreateXML", sig => "conn, string, unsigned : dom" },
{ name => "virDomainFree", sig => "dom : free" },
{ name => "virDomainDestroy", sig => "dom : free" },
{ name => "virDomainLookupByName", sig => "conn, string : dom" },
@@ -198,7 +199,7 @@ print F <<'END';
*/
/* OCaml bindings for libvirt.
- * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
* http://libvirt.org/
*
* This library is free software; you can redistribute it and/or
@@ -310,6 +311,8 @@ sub gen_arg_names
( "$1v", "strv" )
} elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) {
( "$1v", "strv" )
+ } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) {
+ ( "$1v", "strv", "uv" )
} elsif ($sig =~ /^(\w+), u?int : (\w+)$/) {
( "$1v", "iv" )
} elsif ($sig =~ /^(\w+), uuid : (\w+)$/) {
@@ -632,6 +635,22 @@ sub gen_c_code
CAMLreturn (rv);
"
+ } elsif ($sig =~ /^(\w+), string, unsigned : (\w+)$/) {
+ my $c_ret_type = short_name_to_c_type ($2);
+ "\
+ CAMLlocal1 (rv);
+ " . gen_unpack_args ($1) . "
+ char *str = String_val (strv);
+ unsigned int u = Int_val (uv);
+ $c_ret_type r;
+
+ NONBLOCKING (r = $c_name ($1, str, u));
+ CHECK_ERROR (!r, conn, \"$c_name\");
+
+ " . gen_pack_result ($2) . "
+
+ CAMLreturn (rv);
+"
} elsif ($sig =~ /^(\w+), (u?)int : unit$/) {
my $unsigned = $2 eq "u" ? "unsigned " : "";
"\
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 9c9368a..1be023d 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -1,5 +1,5 @@
(* OCaml bindings for libvirt.
- (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
http://libvirt.org/
This library is free software; you can redistribute it and/or
@@ -337,6 +337,20 @@ struct
cpu : int;
}
+ type domain_create_flag =
+ | START_PAUSED
+ | START_AUTODESTROY
+ | START_BYPASS_CACHE
+ | START_FORCE_BOOT
+ | START_VALIDATE
+ let rec int_of_domain_create_flags = function
+ | [] -> 0
+ | START_PAUSED :: flags -> 1 lor int_of_domain_create_flags flags
+ | START_AUTODESTROY :: flags -> 2 lor int_of_domain_create_flags flags
+ | START_BYPASS_CACHE :: flags -> 4 lor int_of_domain_create_flags flags
+ | START_FORCE_BOOT :: flags -> 8 lor int_of_domain_create_flags flags
+ | START_VALIDATE :: flags -> 16 lor int_of_domain_create_flags flags
+
type sched_param = string * sched_param_value
and sched_param_value =
| SchedFieldInt32 of int32 | SchedFieldUInt32 of int32
@@ -385,6 +399,9 @@ struct
let max_peek _ = 65536
external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux"
+ external _create_xml : [>`W] Connect.t -> xml -> int -> rw t = "ocaml_libvirt_domain_create_xml"
+ let create_xml conn xml flags =
+ _create_xml conn xml (int_of_domain_create_flags flags)
external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id"
external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid"
external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid_string"
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 36cd113..8cfcae2 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -1,5 +1,5 @@
(** OCaml bindings for libvirt. *)
-(* (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+(* (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
http://libvirt.org/
This library is free software; you can redistribute it and/or
@@ -430,6 +430,13 @@ sig
cpu : int; (** real CPU number, -1 if offline *)
}
+ type domain_create_flag =
+ | START_PAUSED (** Launch guest in paused state *)
+ | START_AUTODESTROY (** Automatically kill guest on close *)
+ | START_BYPASS_CACHE (** Avoid filesystem cache pollution *)
+ | START_FORCE_BOOT (** Discard any managed save *)
+ | START_VALIDATE (** Validate XML against schema *)
+
type sched_param = string * sched_param_value
and sched_param_value =
| SchedFieldInt32 of int32 | SchedFieldUInt32 of int32
@@ -478,8 +485,10 @@ sig
val create_linux : [>`W] Connect.t -> xml -> rw t
(** Create a new guest domain (not necessarily a Linux one)
- from the given XML.
+ from the given XML. Use {!create_xml} instead.
*)
+ val create_xml : [>`W] Connect.t -> xml -> domain_create_flag list -> rw t
+ (** Create a new guest domain from the given XML. *)
val lookup_by_id : 'a Connect.t -> int -> 'a t
(** Lookup a domain by ID. *)
val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c
index 71e6f61..6e56682 100644
--- a/libvirt/libvirt_c.c
+++ b/libvirt/libvirt_c.c
@@ -6,7 +6,7 @@
*/
/* OCaml bindings for libvirt.
- * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ * (C) Copyright 2007-2015 Richard W.M. Jones, Red Hat Inc.
* http://libvirt.org/
*
* This library is free software; you can redistribute it and/or
@@ -525,6 +525,29 @@ ocaml_libvirt_domain_create_linux (value connv, value strv)
CAMLreturn (rv);
}
+/* Automatically generated binding for virDomainCreateXML.
+ * In generator.pl this function has signature "conn, string, unsigned : dom".
+ */
+
+CAMLprim value
+ocaml_libvirt_domain_create_xml (value connv, value strv, value uv)
+{
+ CAMLparam3 (connv, strv, uv);
+
+ CAMLlocal1 (rv);
+ virConnectPtr conn = Connect_val (connv);
+ char *str = String_val (strv);
+ unsigned int u = Int_val (uv);
+ virDomainPtr r;
+
+ NONBLOCKING (r = virDomainCreateXML (conn, str, u));
+ CHECK_ERROR (!r, conn, "virDomainCreateXML");
+
+ rv = Val_domain (r, connv);
+
+ CAMLreturn (rv);
+}
+
/* Automatically generated binding for virDomainFree.
* In generator.pl this function has signature "dom : free".
*/
--
2.3.1

38
0001-Make-const-the-return-value-of-caml_named_value.patch Normal file
View File

@ -0,0 +1,38 @@
From 75b13978f85b32c7a121aa289d8ebf41ba14ee5a Mon Sep 17 00:00:00 2001
From: Pino Toscano <ptoscano@redhat.com>
Date: Thu, 5 Sep 2019 09:57:09 +0200
Subject: [PATCH] Make const the return value of caml_named_value()
With OCaml >= 4.09 caml_named_value() returns a const value *, so keep
the constness to build also in this case.
Signed-off-by: Pino Toscano <ptoscano@redhat.com>
---
libvirt/libvirt_c_oneoffs.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 6f56f10..e23c0db 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -1207,7 +1207,7 @@ ocaml_libvirt_event_run_default_impl (value unitv)
#define DOMAIN_CALLBACK_BEGIN(NAME) \
value connv, domv, callback_id, result; \
connv = domv = callback_id = result = Val_int(0); \
- static value *callback = NULL; \
+ static const value *callback = NULL; \
caml_leave_blocking_section(); \
if (callback == NULL) \
callback = caml_named_value(NAME); \
@@ -1433,7 +1433,7 @@ timeout_callback(int timer, void *opaque)
{
value callback_id, result;
callback_id = result = Val_int(0);
- static value *callback = NULL;
+ static const value *callback = NULL;
caml_leave_blocking_section();
if (callback == NULL)
callback = caml_named_value("Libvirt.timeout_callback");
--
2.23.0

57
0001-Remove-unused-not_supported-function.patch
View File

@ -1,57 +0,0 @@
From 8853f5a49587f00a7d2a5c8c7e52480a16bbdb02 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Fri, 5 Feb 2016 16:28:34 +0000
Subject: [PATCH] Remove unused 'not_supported' function.
Found by compiling under GCC 6. The warning was:
In file included from libvirt_c.c:2058:0:
libvirt_c_epilogue.c:89:1: error: 'not_supported' defined but not used [-Werror=unused-function]
not_supported (const char *fn)
^~~~~~~~~~~~~
---
libvirt/libvirt_c_epilogue.c | 15 ---------------
libvirt/libvirt_c_prologue.c | 1 -
2 files changed, 16 deletions(-)
diff --git a/libvirt/libvirt_c_epilogue.c b/libvirt/libvirt_c_epilogue.c
index 4972e50..fa592c9 100644
--- a/libvirt/libvirt_c_epilogue.c
+++ b/libvirt/libvirt_c_epilogue.c
@@ -84,21 +84,6 @@ _raise_virterror (const char *fn)
(void) caml__frame;
}
-/* Raise an error if a function is not supported. */
-static void
-not_supported (const char *fn)
-{
- CAMLparam0 ();
- CAMLlocal1 (fnv);
-
- fnv = caml_copy_string (fn);
- caml_raise_with_arg (*caml_named_value ("ocaml_libvirt_not_supported"), fnv);
-
- /*NOTREACHED*/
- /* Suppresses a compiler warning. */
- (void) caml__frame;
-}
-
/* Convert the virErrorNumber, virErrorDomain and virErrorLevel enums
* into values (longs because they are variants in OCaml).
*
diff --git a/libvirt/libvirt_c_prologue.c b/libvirt/libvirt_c_prologue.c
index bf972e9..710c0d6 100644
--- a/libvirt/libvirt_c_prologue.c
+++ b/libvirt/libvirt_c_prologue.c
@@ -25,7 +25,6 @@ typedef value (*Val_ptr_t) (void *);
static value Val_opt (void *ptr, Val_ptr_t Val_ptr);
/*static value option_default (value option, value deflt);*/
static void _raise_virterror (const char *fn) Noreturn;
-static void not_supported (const char *fn) Noreturn;
static value Val_virterror (virErrorPtr err);
/* Use this around synchronous libvirt API calls to release the OCaml
--
2.5.0

1864
0001-Suppress-errors-to-stderr-and-use-thread-local-virEr.patch
View File

File diff suppressed because it is too large Load Diff

35
0001-Use-C99-standard-int64_t-instead-of-OCaml-defined-an.patch
View File

@ -1,35 +0,0 @@
From 21ac993da0a187821e812fe7b5b31a426121a546 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 30 Aug 2014 19:10:19 +0100
Subject: [PATCH] Use C99 standard int64_t instead of OCaml defined (and soon
to go) int64.
---
libvirt/libvirt_c_oneoffs.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 3bb572f..06b3852 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -140,7 +140,7 @@ ocaml_libvirt_connect_node_get_free_memory (value connv)
NONBLOCKING (r = virNodeGetFreeMemory (conn));
CHECK_ERROR (r == 0, conn, "virNodeGetFreeMemory");
- rv = caml_copy_int64 ((int64) r);
+ rv = caml_copy_int64 ((int64_t) r);
CAMLreturn (rv);
}
@@ -161,7 +161,7 @@ ocaml_libvirt_connect_node_get_cells_free_memory (value connv,
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);
}
--
2.0.4

78
0001-Use-g-warn-error.patch
View File

@ -1,78 +0,0 @@
From 2ba6898b4dc121b00078e36d5416b3caadd5d05e Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 14:12:50 +0100
Subject: [PATCH 1/5] Use -g -warn-error.
Use -g for ocamlopt. ocamlopt has supported generating DWARF
information for quite a long time.
Also use -warn-error with the same set of warnings as is used
by libguestfs.
Fix a warning in examples/get_cpu_stats.ml found by enabling
-warn-error.
---
examples/Makefile.in | 4 ++--
examples/get_cpu_stats.ml | 2 ++
libvirt/Makefile.in | 6 +++---
3 files changed, 7 insertions(+), 5 deletions(-)
diff --git a/examples/Makefile.in b/examples/Makefile.in
index 041e382..46006a0 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -18,10 +18,10 @@
OCAMLFIND = @OCAMLFIND@
OCAMLCPACKAGES := -package unix -I ../libvirt
-OCAMLCFLAGS := -g
+OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3
OCAMLCLIBS := -linkpkg
OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
-OCAMLOPTFLAGS :=
+OCAMLOPTFLAGS := -g -warn-error CDEFLMPSUVYZX-3
OCAMLOPTLIBS := $(OCAMLCLIBS)
export LIBRARY_PATH=../libvirt
diff --git a/examples/get_cpu_stats.ml b/examples/get_cpu_stats.ml
index d7a8d0c..814c85e 100644
--- a/examples/get_cpu_stats.ml
+++ b/examples/get_cpu_stats.ml
@@ -19,9 +19,11 @@ let () =
let conn = C.connect_readonly () in
+ (*
let nr_pcpus =
let info = C.get_node_info conn in
C.maxcpus_of_node_info info in
+ *)
let stats =
let dom = D.lookup_by_name conn domname in
diff --git a/libvirt/Makefile.in b/libvirt/Makefile.in
index f7c04bb..cf614fc 100644
--- a/libvirt/Makefile.in
+++ b/libvirt/Makefile.in
@@ -31,15 +31,15 @@ OCAMLMKLIB = @OCAMLMKLIB@
ifneq ($(OCAMLFIND),)
OCAMLCPACKAGES := -package unix
-OCAMLCFLAGS := -g
+OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3
OCAMLCLIBS := -linkpkg
else
OCAMLCINCS :=
-OCAMLCFLAGS := -g
+OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3
OCAMLCLIBS := unix.cma
endif
-OCAMLOPTFLAGS :=
+OCAMLOPTFLAGS := $(OCAMLCFLAGS)
ifneq ($(OCAMLFIND),)
OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
OCAMLOPTLIBS := $(OCAMLCLIBS)
--
2.9.3

76
0001-Use-safe-string-and-fix-the-library.patch
View File

@ -1,76 +0,0 @@
From bab7f84ade84ceaddb08b6948792d49b3d04b897 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Wed, 8 Nov 2017 16:52:58 +0000
Subject: [PATCH] Use -safe-string and fix the library.
Note this changes the type of the cpumap from string to bytes,
since (by the design of the API) it must be mutated.
---
libvirt/Makefile.in | 4 ++--
libvirt/libvirt.ml | 10 +++++-----
libvirt/libvirt.mli | 6 +++---
3 files changed, 10 insertions(+), 10 deletions(-)
diff --git a/libvirt/Makefile.in b/libvirt/Makefile.in
index cf614fc..1eb846b 100644
--- a/libvirt/Makefile.in
+++ b/libvirt/Makefile.in
@@ -31,11 +31,11 @@ OCAMLMKLIB = @OCAMLMKLIB@
ifneq ($(OCAMLFIND),)
OCAMLCPACKAGES := -package unix
-OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3
+OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3 -safe-string
OCAMLCLIBS := -linkpkg
else
OCAMLCINCS :=
-OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3
+OCAMLCFLAGS := -g -warn-error CDEFLMPSUVYZX-3 -safe-string
OCAMLCLIBS := unix.cma
endif
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index d03a127..7e1e470 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -92,13 +92,13 @@ struct
(* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in <libvirt.h>. *)
let use_cpu cpumap cpu =
- cpumap.[cpu/8] <-
- Char.chr (Char.code cpumap.[cpu/8] lor (1 lsl (cpu mod 8)))
+ Bytes.set cpumap (cpu/8)
+ (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) lor (1 lsl (cpu mod 8))))
let unuse_cpu cpumap cpu =
- cpumap.[cpu/8] <-
- Char.chr (Char.code cpumap.[cpu/8] land (lnot (1 lsl (cpu mod 8))))
+ Bytes.set cpumap (cpu/8)
+ (Char.chr (Char.code (Bytes.get cpumap (cpu/8)) land (lnot (1 lsl (cpu mod 8)))))
let cpu_usable cpumaps maplen vcpu cpu =
- Char.code cpumaps.[vcpu*maplen + cpu/8] land (1 lsl (cpu mod 8)) <> 0
+ Char.code (Bytes.get cpumaps (vcpu*maplen + cpu/8)) land (1 lsl (cpu mod 8)) <> 0
external set_keep_alive : [>`R] t -> int -> int -> unit = "ocaml_libvirt_connect_set_keep_alive"
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index dc0033b..87f50f5 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -376,11 +376,11 @@ sig
CPU map between a single virtual and all physical CPUs of a domain.
*)
- val use_cpu : string -> int -> unit
+ val use_cpu : bytes -> int -> unit
(** [use_cpu cpumap cpu] marks [cpu] as usable in [cpumap]. *)
- val unuse_cpu : string -> int -> unit
+ val unuse_cpu : bytes -> int -> unit
(** [unuse_cpu cpumap cpu] marks [cpu] as not usable in [cpumap]. *)
- val cpu_usable : string -> int -> int -> int -> bool
+ val cpu_usable : bytes -> int -> int -> int -> bool
(** [cpu_usable cpumaps maplen vcpu cpu] checks returns true iff the
[cpu] is usable by [vcpu]. *)
--
2.13.1

74
0001-block_peek-memory_peek-Use-bytes-for-return-buffer.patch Normal file
View File

@ -0,0 +1,74 @@
From 29709872404fad20a9822c43a831f30b7b09f34a Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sun, 19 Jan 2020 12:58:17 +0000
Subject: [PATCH 1/3] block_peek, memory_peek: Use bytes for return buffer.
Strings are immutable in modern OCaml.
---
libvirt/libvirt.ml | 4 ++--
libvirt/libvirt.mli | 4 ++--
libvirt/libvirt_c_oneoffs.c | 4 ++--
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 7f9d0e4..bdb9460 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -731,8 +731,8 @@ struct
external migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t = "ocaml_libvirt_domain_migrate_bytecode" "ocaml_libvirt_domain_migrate_native"
external block_stats : [>`R] t -> string -> block_stats = "ocaml_libvirt_domain_block_stats"
external interface_stats : [>`R] t -> string -> interface_stats = "ocaml_libvirt_domain_interface_stats"
- external block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native"
- external memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native"
+ external block_peek : [>`W] t -> string -> int64 -> int -> bytes -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native"
+ external memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> bytes -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native"
external get_all_domain_stats : [>`R] Connect.t -> stats_type list -> get_all_domain_stats_flag list -> domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 0d74199..7900392 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -708,7 +708,7 @@ sig
val interface_stats : [>`R] t -> string -> interface_stats
(** Returns network interface stats. *)
- val block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit
+ val block_peek : [>`W] t -> string -> int64 -> int -> bytes -> int -> unit
(** [block_peek dom path offset size buf boff] reads [size] bytes at
[offset] in the domain's [path] block device.
@@ -717,7 +717,7 @@ sig
See also {!max_peek}. *)
val memory_peek : [>`W] t -> memory_flag list -> int64 -> int ->
- string -> int -> unit
+ bytes -> int -> unit
(** [memory_peek dom Virtual offset size] reads [size] bytes
at [offset] in the domain's virtual memory.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 40384e8..8468c73 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -1057,7 +1057,7 @@ ocaml_libvirt_domain_block_peek_native (value domv, value pathv, value offsetv,
const char *path = String_val (pathv);
unsigned long long offset = Int64_val (offsetv);
size_t size = Int_val (sizev);
- char *buffer = String_val (bufferv);
+ unsigned char *buffer = Bytes_val (bufferv);
int boff = Int_val (boffv);
int r;
@@ -1089,7 +1089,7 @@ ocaml_libvirt_domain_memory_peek_native (value domv, value flagsv, value offsetv
int flags = 0;
unsigned long long offset = Int64_val (offsetv);
size_t size = Int_val (sizev);
- char *buffer = String_val (bufferv);
+ unsigned char *buffer = Bytes_val (bufferv);
int boff = Int_val (boffv);
int r;
--
2.24.1

32
0002-Don-t-bother-checking-return-from-virInitialize.patch
View File

@ -1,32 +0,0 @@
From 06b24089986523806d386b9e3cfa4fcf5eeb87e6 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 17 Mar 2015 12:53:29 +0000
Subject: [PATCH 2/2] Don't bother checking return from virInitialize.
The Perl bindings don't do this, and it seems that the call can never
fail, or if it does we don't care.
---
libvirt/libvirt_c_oneoffs.c | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 32e5a4b..5d82194 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -1229,12 +1229,9 @@ CAMLprim value
ocaml_libvirt_init (value unit)
{
CAMLparam1 (unit);
- CAMLlocal1 (rv);
- int r;
virSetErrorFunc (NULL, ignore_errors);
- r = virInitialize ();
- CHECK_ERROR (r == -1, "virInitialize");
+ virInitialize ();
CAMLreturn (Val_unit);
}
--
2.3.1

113
0002-String_val-returns-const-char-in-OCaml-4.10.patch Normal file
View File

@ -0,0 +1,113 @@
From 3705b9bdcd04dc86474c62e1c8dd8759669842bc Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sun, 19 Jan 2020 12:59:09 +0000
Subject: [PATCH 2/3] String_val returns const char * in OCaml 4.10.
This should be compatible with earlier versions of OCaml
too since we are just assigning a char * to a const char *.
---
libvirt/generator.pl | 14 +++++++-------
libvirt/libvirt_c_oneoffs.c | 6 +++---
2 files changed, 10 insertions(+), 10 deletions(-)
diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index ac3dd65..aff371b 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -593,7 +593,7 @@ sub gen_c_code
} elsif ($sig =~ /^(\w+), string : unit$/) {
"\
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
int r;
NONBLOCKING (r = $c_name ($1, str));
@@ -605,7 +605,7 @@ sub gen_c_code
"\
CAMLlocal1 (rv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
int r;
NONBLOCKING (r = $c_name ($1, str, 0));
@@ -618,7 +618,7 @@ sub gen_c_code
"\
CAMLlocal1 (rv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
$c_ret_type r;
NONBLOCKING (r = $c_name ($1, str));
@@ -633,7 +633,7 @@ sub gen_c_code
"\
CAMLlocal1 (rv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
$c_ret_type r;
NONBLOCKING (r = $c_name ($1, str, 0));
@@ -648,7 +648,7 @@ sub gen_c_code
"\
CAMLlocal1 (rv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
unsigned int u = Int_val (uv);
$c_ret_type r;
@@ -735,7 +735,7 @@ sub gen_c_code
"\
CAMLlocal2 (rv, connv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
$c_ret_type r;
NONBLOCKING (r = $c_name ($1, str));
@@ -751,7 +751,7 @@ sub gen_c_code
"\
CAMLlocal2 (rv, connv);
" . gen_unpack_args ($1) . "
- char *str = String_val (strv);
+ const char *str = String_val (strv);
$c_ret_type r;
NONBLOCKING (r = $c_name ($1, str, 0));
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 8468c73..fc2ac13 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -601,7 +601,7 @@ ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv)
int nparams = Wosize_val (paramsv);
virSchedParameterPtr params;
int r, i;
- char *name;
+ const char *name;
params = malloc (sizeof (*params) * nparams);
if (params == NULL)
@@ -1005,7 +1005,7 @@ ocaml_libvirt_domain_block_stats (value domv, value pathv)
CAMLparam2 (domv, pathv);
CAMLlocal2 (rv,v);
virDomainPtr dom = Domain_val (domv);
- char *path = String_val (pathv);
+ const char *path = String_val (pathv);
struct _virDomainBlockStats stats;
int r;
@@ -1028,7 +1028,7 @@ ocaml_libvirt_domain_interface_stats (value domv, value pathv)
CAMLparam2 (domv, pathv);
CAMLlocal2 (rv,v);
virDomainPtr dom = Domain_val (domv);
- char *path = String_val (pathv);
+ const char *path = String_val (pathv);
struct _virDomainInterfaceStats stats;
int r;
--
2.24.1

44
0002-Update-dependencies.patch
View File

@ -1,44 +0,0 @@
From ca9a3227f9937f9cdeb84126f1c74502c9a25047 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 14:13:47 +0100
Subject: [PATCH 2/5] Update dependencies.
---
examples/.depend | 8 ++++----
libvirt/.depend | 6 +++---
2 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/examples/.depend b/examples/.depend
index b305b76..b5379d8 100644
--- a/examples/.depend
+++ b/examples/.depend
@@ -1,8 +1,8 @@
-node_info.cmo : ../libvirt/libvirt.cmi
-node_info.cmx : ../libvirt/libvirt.cmx
-get_cpu_stats.cmo : ../libvirt/libvirt.cmi
-get_cpu_stats.cmx : ../libvirt/libvirt.cmx
domain_events.cmo : ../libvirt/libvirt.cmi
domain_events.cmx : ../libvirt/libvirt.cmx
+get_cpu_stats.cmo : ../libvirt/libvirt.cmi
+get_cpu_stats.cmx : ../libvirt/libvirt.cmx
list_domains.cmo : ../libvirt/libvirt.cmi
list_domains.cmx : ../libvirt/libvirt.cmx
+node_info.cmo : ../libvirt/libvirt.cmi
+node_info.cmx : ../libvirt/libvirt.cmx
diff --git a/libvirt/.depend b/libvirt/.depend
index 7d32e13..ee1180c 100644
--- a/libvirt/.depend
+++ b/libvirt/.depend
@@ -1,6 +1,6 @@
-libvirt_version.cmi :
+libvirt.cmo : libvirt.cmi
+libvirt.cmx : libvirt.cmi
libvirt.cmi :
libvirt_version.cmo : libvirt_version.cmi
libvirt_version.cmx : libvirt_version.cmi
-libvirt.cmo : libvirt.cmi
-libvirt.cmx : libvirt.cmi
+libvirt_version.cmi :
--
2.9.3

393
0003-Add-a-binding-for-virConnectGetAllDomainStats-RHBZ-1.patch
View File

@ -1,393 +0,0 @@
From 380f1e05b244ae4750ca5101b5b5a182dcd0d1fd Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 10:08:06 +0100
Subject: [PATCH 3/5] Add a binding for virConnectGetAllDomainStats
(RHBZ#1390171).
---
.gitignore | 2 +
Makefile.in | 1 +
examples/.depend | 2 +
examples/Makefile.in | 13 ++++-
examples/get_all_domain_stats.ml | 65 +++++++++++++++++++++
libvirt/libvirt.ml | 23 ++++++++
libvirt/libvirt.mli | 28 +++++++++
libvirt/libvirt_c_oneoffs.c | 119 ++++++++++++++++++++++++++++++++++++++-
8 files changed, 250 insertions(+), 3 deletions(-)
create mode 100644 examples/get_all_domain_stats.ml
diff --git a/.gitignore b/.gitignore
index 71a245e..366eb29 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
+.gdb_history
META
ocaml-libvirt-*.tar.gz
ocaml-libvirt-*.exe
@@ -27,6 +28,7 @@ core.*
*~
libvirt/libvirt_version.ml
examples/domain_events
+examples/get_all_domain_stats
examples/get_cpu_stats
examples/list_domains
examples/node_info
diff --git a/Makefile.in b/Makefile.in
index 3b8b7ec..2605ddd 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -41,6 +41,7 @@ clean:
rm -f examples/node_info
rm -f examples/get_cpu_stats
rm -f examples/domain_events
+ rm -f examples/get_all_domain_stats
distclean: clean
rm -f config.h config.log config.status configure
diff --git a/examples/.depend b/examples/.depend
index b5379d8..11f2c7c 100644
--- a/examples/.depend
+++ b/examples/.depend
@@ -1,5 +1,7 @@
domain_events.cmo : ../libvirt/libvirt.cmi
domain_events.cmx : ../libvirt/libvirt.cmx
+get_all_domain_stats.cmo : ../libvirt/libvirt.cmi
+get_all_domain_stats.cmx : ../libvirt/libvirt.cmx
get_cpu_stats.cmo : ../libvirt/libvirt.cmi
get_cpu_stats.cmx : ../libvirt/libvirt.cmx
list_domains.cmo : ../libvirt/libvirt.cmi
diff --git a/examples/Makefile.in b/examples/Makefile.in
index 46006a0..8530edc 100644
--- a/examples/Makefile.in
+++ b/examples/Makefile.in
@@ -27,7 +27,8 @@ OCAMLOPTLIBS := $(OCAMLCLIBS)
export LIBRARY_PATH=../libvirt
export LD_LIBRARY_PATH=../libvirt
-BYTE_TARGETS := list_domains node_info get_cpu_stats domain_events
+BYTE_TARGETS := list_domains node_info get_cpu_stats \
+ get_all_domain_stats domain_events
OPT_TARGETS := $(BYTE_TARGETS:%=%.opt)
all: $(BYTE_TARGETS)
@@ -64,6 +65,16 @@ get_cpu_stats.opt: get_cpu_stats.cmx
$(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
../libvirt/mllibvirt.cmxa -o $@ $<
+get_all_domain_stats: get_all_domain_stats.cmo
+ $(OCAMLFIND) ocamlc \
+ $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ ../libvirt/mllibvirt.cma -o $@ $<
+
+get_all_domain_stats.opt: get_all_domain_stats.cmx
+ $(OCAMLFIND) ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ ../libvirt/mllibvirt.cmxa -o $@ $<
+
domain_events: domain_events.cmo
$(OCAMLFIND) ocamlc \
$(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
diff --git a/examples/get_all_domain_stats.ml b/examples/get_all_domain_stats.ml
new file mode 100644
index 0000000..4375639
--- /dev/null
+++ b/examples/get_all_domain_stats.ml
@@ -0,0 +1,65 @@
+(* Example of using Domain.get_all_domain_stats (virConnectGetAllDomainStats).
+ * Usage: get_all_domain_stats
+ * http://libvirt.org/
+ *)
+
+open Printf
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+let print_stats stats =
+ try
+ Array.iter (
+ fun { D.dom = dom; D.params = params } ->
+ printf "domain %s:\n" (D.get_name dom);
+ Array.iteri (
+ fun i (field, value) ->
+ printf "\t%-20s = " field;
+ (match value with
+ | D.TypedFieldInt32 i -> printf "%ld" i
+ | D.TypedFieldUInt32 i -> printf "%ld" i
+ | D.TypedFieldInt64 i -> printf "%Ld" i
+ | D.TypedFieldUInt64 i -> printf "%Ld" i
+ | D.TypedFieldFloat f -> printf "%g" f
+ | D.TypedFieldBool b -> printf "%b" b
+ | D.TypedFieldString s -> printf "%S" s);
+ printf "\n";
+ ) params;
+ printf "\n"
+ ) stats
+ with
+ Libvirt.Virterror err ->
+ eprintf "error: %s\n" (Libvirt.Virterror.to_string err)
+
+let () =
+ if Array.length Sys.argv <> 1 then (
+ eprintf "error: get_all_domain_stats\n";
+ exit 1
+ );
+
+ let conn = C.connect_readonly () in
+
+ let what_stats = [D.StatsCpuTotal; D.StatsInterface; D.StatsBlock] in
+ let flags = [D.GetAllDomainsStatsActive; D.GetAllDomainsStatsInactive] in
+
+ let quit = ref false in
+
+ while not !quit do
+ let stats = D.get_all_domain_stats conn what_stats flags in
+
+ if stats <> [||] then print_stats stats
+ else (
+ printf "no guests found\n";
+ quit := true
+ );
+ flush stdout;
+
+ (* Run the garbage collector which is a good way to check for
+ * memory corruption errors and reference counting issues in
+ * libvirt. You shouldn't do this in ordinary programs.
+ *)
+ Gc.compact ();
+
+ if not !quit then Unix.sleep 3
+ done
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index 1be023d..ce1878a 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -392,6 +392,27 @@ struct
tx_drop : int64;
}
+ type get_all_domain_stats_flag =
+ | GetAllDomainsStatsActive
+ | GetAllDomainsStatsInactive
+ | GetAllDomainsStatsOther
+ | GetAllDomainsStatsPaused
+ | GetAllDomainsStatsPersistent
+ | GetAllDomainsStatsRunning
+ | GetAllDomainsStatsShutoff
+ | GetAllDomainsStatsTransient
+ | GetAllDomainsStatsBacking
+ | GetAllDomainsStatsEnforceStats
+
+ type stats_type =
+ | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
+ | StatsInterface | StatsBlock | StatsPerf
+
+ type 'a domain_stats_record = {
+ dom : 'a t;
+ params : typed_param array;
+ }
+
(* The maximum size for Domain.memory_peek and Domain.block_peek
* supported by libvirt. This may change with different versions
* of libvirt in the future, hence it's a function.
@@ -446,6 +467,8 @@ struct
external block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native"
external memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native"
+ external get_all_domain_stats : 'a Connect.t -> stats_type list -> get_all_domain_stats_flag list -> 'a domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
+
external const : [>`R] t -> ro t = "%identity"
let get_domains conn flags =
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index 8cfcae2..d1b5992 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -478,6 +478,27 @@ sig
tx_drop : int64;
}
+ type get_all_domain_stats_flag =
+ | GetAllDomainsStatsActive
+ | GetAllDomainsStatsInactive
+ | GetAllDomainsStatsOther
+ | GetAllDomainsStatsPaused
+ | GetAllDomainsStatsPersistent
+ | GetAllDomainsStatsRunning
+ | GetAllDomainsStatsShutoff
+ | GetAllDomainsStatsTransient
+ | GetAllDomainsStatsBacking
+ | GetAllDomainsStatsEnforceStats
+
+ type stats_type =
+ | StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
+ | StatsInterface | StatsBlock | StatsPerf
+
+ type 'a domain_stats_record = {
+ dom : 'a t;
+ params : typed_param array;
+ }
+
val max_peek : [>`R] t -> int
(** Maximum size supported by the {!block_peek} and {!memory_peek}
functions. If you want to peek more than this then you must
@@ -615,6 +636,13 @@ sig
See also {!max_peek}. *)
+ external get_all_domain_stats : 'a Connect.t -> stats_type list -> get_all_domain_stats_flag list -> 'a domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
+ (** [get_all_domain_stats conn stats flags] allows you to read
+ all stats across multiple/all domains in a single call.
+
+ See the libvirt documentation for
+ [virConnectGetAllDomainStats]. *)
+
external const : [>`R] t -> ro t = "%identity"
(** [const dom] turns a read/write domain handle into a read-only
domain handle. Note that the opposite operation is impossible.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 5d82194..17412f5 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -1,5 +1,5 @@
/* 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
@@ -184,7 +184,6 @@ ocaml_libvirt_connect_set_keep_alive(value connv,
CAMLreturn(Val_unit);
}
-
CAMLprim value
ocaml_libvirt_domain_get_id (value domv)
{
@@ -560,6 +559,122 @@ ocaml_libvirt_domain_get_cpu_stats (value domv)
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;
+
+ /* 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 */
+ virDomainRef (rstats[i]->dom);
+ Store_field (dsv, 0, Val_domain (rstats[i]->dom, connv));
+
+ 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)
{
--
2.9.3

68
0003-Don-t-try-to-memcpy-into-a-String_val.patch Normal file
View File

@ -0,0 +1,68 @@
From 3d3d6af425d369200a7a62a127adf640d94a38a3 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sun, 19 Jan 2020 13:02:16 +0000
Subject: [PATCH 3/3] Don't try to memcpy into a String_val.
In OCaml 4.10 String_val returns const char *, so we cannot use it as
the destination for memcpy. Use Bytes_val instead.
---
libvirt/generator.pl | 2 +-
libvirt/libvirt_c_oneoffs.c | 8 ++++----
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/libvirt/generator.pl b/libvirt/generator.pl
index aff371b..463a19b 100755
--- a/libvirt/generator.pl
+++ b/libvirt/generator.pl
@@ -440,7 +440,7 @@ sub gen_c_code
/* UUIDs are byte arrays with a fixed length. */
rv = caml_alloc_string (VIR_UUID_BUFLEN);
- memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN);
+ memcpy (Bytes_val (rv), uuid, VIR_UUID_BUFLEN);
CAMLreturn (rv);
"
} elsif ($sig =~ /^(\w+) : uuid string$/) {
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index fc2ac13..e8472b7 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -394,7 +394,7 @@ ocaml_libvirt_connect_call_auth_default_callback (value listv)
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);
+ memcpy (Bytes_val (v), cred->result, cred->resultlen);
optv = caml_alloc (1, 0);
Store_field (optv, 0, v);
} else
@@ -715,7 +715,7 @@ ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv)
/* Copy the bitmap. */
strv = caml_alloc_string (maxinfo * maplen);
- memcpy (String_val (strv), cpumaps, maxinfo * maplen);
+ memcpy (Bytes_val (strv), cpumaps, maxinfo * maplen);
/* Allocate the tuple and return it. */
rv = caml_alloc_tuple (3);
@@ -900,7 +900,7 @@ ocaml_libvirt_domain_get_all_domain_stats (value connv,
*/
v = caml_alloc_string (VIR_UUID_BUFLEN);
virDomainGetUUID (rstats[i]->dom, uuid);
- memcpy (String_val (v), uuid, VIR_UUID_BUFLEN);
+ memcpy (Bytes_val (v), uuid, VIR_UUID_BUFLEN);
Store_field (dsv, 0, v);
tpv = caml_alloc (rstats[i]->nparams, 0); /* typed_param array */
@@ -1646,7 +1646,7 @@ ocaml_libvirt_secret_get_value (value secv)
CHECK_ERROR (secval == NULL, "virSecretGetValue");
rv = caml_alloc_string (size);
- memcpy (String_val (rv), secval, size);
+ memcpy (Bytes_val (rv), secval, size);
free (secval);
CAMLreturn (rv);
--
2.24.1

42
0004-examples-Print-more-stats-in-the-get_all_domain_stat.patch
View File

@ -1,42 +0,0 @@
From 2bb6200934090f34f81d1badb9a55f5a86a7fb32 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 13:11:09 +0100
Subject: [PATCH 4/5] examples: Print more stats in the get_all_domain_stats.ml
example.
Updates commit 380f1e05b244ae4750ca5101b5b5a182dcd0d1fd.
---
examples/get_all_domain_stats.ml | 13 ++++++++++---
1 file changed, 10 insertions(+), 3 deletions(-)
diff --git a/examples/get_all_domain_stats.ml b/examples/get_all_domain_stats.ml
index 4375639..cc86da6 100644
--- a/examples/get_all_domain_stats.ml
+++ b/examples/get_all_domain_stats.ml
@@ -40,13 +40,20 @@ let () =
let conn = C.connect_readonly () in
- let what_stats = [D.StatsCpuTotal; D.StatsInterface; D.StatsBlock] in
- let flags = [D.GetAllDomainsStatsActive; D.GetAllDomainsStatsInactive] in
+ let what = [
+ D.StatsState;
+ D.StatsCpuTotal;
+ D.StatsBalloon;
+ D.StatsVcpu;
+ D.StatsInterface;
+ D.StatsBlock;
+ ] in
+ let who = [] in (* empty list means returns all domains *)
let quit = ref false in
while not !quit do
- let stats = D.get_all_domain_stats conn what_stats flags in
+ let stats = D.get_all_domain_stats conn what who in
if stats <> [||] then print_stats stats
else (
--
2.9.3

127
0005-Change-binding-of-virConnectGetAllDomainStats-to-ret.patch
View File

@ -1,127 +0,0 @@
From 3169af3337938e18bf9ecc6ce936d644e14ff3de Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 13:52:51 +0100
Subject: [PATCH 5/5] Change binding of virConnectGetAllDomainStats to return
dom UUID.
The virDomainPtr object returned by this binding isn't a reliable
virDomainPtr object. The only thing we can safely do with it is to
get its UUID. Modify the API correspondingly.
Updates commit 380f1e05b244ae4750ca5101b5b5a182dcd0d1fd.
---
examples/get_all_domain_stats.ml | 7 ++++---
libvirt/libvirt.ml | 6 +++---
libvirt/libvirt.mli | 6 +++---
libvirt/libvirt_c_oneoffs.c | 13 +++++++++++--
4 files changed, 21 insertions(+), 11 deletions(-)
diff --git a/examples/get_all_domain_stats.ml b/examples/get_all_domain_stats.ml
index cc86da6..be91f77 100644
--- a/examples/get_all_domain_stats.ml
+++ b/examples/get_all_domain_stats.ml
@@ -8,10 +8,11 @@ open Printf
module C = Libvirt.Connect
module D = Libvirt.Domain
-let print_stats stats =
+let print_stats conn stats =
try
Array.iter (
- fun { D.dom = dom; D.params = params } ->
+ fun { D.dom_uuid = uuid; D.params = params } ->
+ let dom = D.lookup_by_uuid conn uuid in
printf "domain %s:\n" (D.get_name dom);
Array.iteri (
fun i (field, value) ->
@@ -55,7 +56,7 @@ let () =
while not !quit do
let stats = D.get_all_domain_stats conn what who in
- if stats <> [||] then print_stats stats
+ if stats <> [||] then print_stats conn stats
else (
printf "no guests found\n";
quit := true
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
index ce1878a..d03a127 100644
--- a/libvirt/libvirt.ml
+++ b/libvirt/libvirt.ml
@@ -408,8 +408,8 @@ struct
| StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
| StatsInterface | StatsBlock | StatsPerf
- type 'a domain_stats_record = {
- dom : 'a t;
+ type domain_stats_record = {
+ dom_uuid : uuid;
params : typed_param array;
}
@@ -467,7 +467,7 @@ struct
external block_peek : [>`W] t -> string -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_block_peek_bytecode" "ocaml_libvirt_domain_block_peek_native"
external memory_peek : [>`W] t -> memory_flag list -> int64 -> int -> string -> int -> unit = "ocaml_libvirt_domain_memory_peek_bytecode" "ocaml_libvirt_domain_memory_peek_native"
- external get_all_domain_stats : 'a Connect.t -> stats_type list -> get_all_domain_stats_flag list -> 'a domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
+ external get_all_domain_stats : [>`R] Connect.t -> stats_type list -> get_all_domain_stats_flag list -> domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
external const : [>`R] t -> ro t = "%identity"
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
index d1b5992..dc0033b 100644
--- a/libvirt/libvirt.mli
+++ b/libvirt/libvirt.mli
@@ -494,8 +494,8 @@ sig
| StatsState | StatsCpuTotal | StatsBalloon | StatsVcpu
| StatsInterface | StatsBlock | StatsPerf
- type 'a domain_stats_record = {
- dom : 'a t;
+ type domain_stats_record = {
+ dom_uuid : uuid;
params : typed_param array;
}
@@ -636,7 +636,7 @@ sig
See also {!max_peek}. *)
- external get_all_domain_stats : 'a Connect.t -> stats_type list -> get_all_domain_stats_flag list -> 'a domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
+ external get_all_domain_stats : [>`R] Connect.t -> stats_type list -> get_all_domain_stats_flag list -> domain_stats_record array = "ocaml_libvirt_domain_get_all_domain_stats"
(** [get_all_domain_stats conn stats flags] allows you to read
all stats across multiple/all domains in a single call.
diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c
index 17412f5..958ba69 100644
--- a/libvirt/libvirt_c_oneoffs.c
+++ b/libvirt/libvirt_c_oneoffs.c
@@ -570,6 +570,7 @@ ocaml_libvirt_domain_get_all_domain_stats (value 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)) {
@@ -619,8 +620,16 @@ ocaml_libvirt_domain_get_all_domain_stats (value connv,
rv = caml_alloc (r, 0); /* domain_stats_record array. */
for (i = 0; i < r; ++i) {
dsv = caml_alloc (2, 0); /* domain_stats_record */
- virDomainRef (rstats[i]->dom);
- Store_field (dsv, 0, Val_domain (rstats[i]->dom, connv));
+
+ /* 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) {
--
2.9.3

BIN
ocaml-libvirt-0.6.1.4.tar.gz
View File

Binary file not shown.

BIN
ocaml-libvirt-0.6.1.5.tar.gz Normal file
View File

Binary file not shown.

42
ocaml-libvirt.spec
View File

@ -1,39 +1,23 @@
Name: ocaml-libvirt Name: ocaml-libvirt
Version: 0.6.1.4 Version: 0.6.1.5
Release: 30 Release: 1
Summary: OCaml binding for libvirt Summary: OCaml binding for libvirt
License: LGPLv2+ License: LGPLv2+
URL: http://libvirt.org/ocaml/ URL: http://libvirt.org/ocaml/
Source0: http://libvirt.org/sources/ocaml/%{name}-%{version}.tar.gz Source0: http://libvirt.org/sources/ocaml/%{name}-%{version}.tar.gz
# Upstream patch to fix int types. # Fixes build with OCaml >= 4.09.
Patch0001: 0001-Use-C99-standard-int64_t-instead-of-OCaml-defined-an.patch # Upstream commit 75b13978f85b32c7a121aa289d8ebf41ba14ee5a.
Patch1: 0001-Make-const-the-return-value-of-caml_named_value.patch
# Upstream patch to add virDomainCreateXML binding.
Patch0002: 0001-Add-a-binding-for-virDomainCreateXML.patch # Fixes for OCaml 4.10, sent upstream 2020-01-19.
Patch2: 0001-block_peek-memory_peek-Use-bytes-for-return-buffer.patch
# Upstream patches to fix error handling. Patch3: 0002-String_val-returns-const-char-in-OCaml-4.10.patch
Patch0003: 0001-Suppress-errors-to-stderr-and-use-thread-local-virEr.patch Patch4: 0003-Don-t-try-to-memcpy-into-a-String_val.patch
Patch0004: 0002-Don-t-bother-checking-return-from-virInitialize.patch
# Upstream patch to remove unused function.
Patch0005: 0001-Remove-unused-not_supported-function.patch
# Upstream patches to tidy up warnings.
Patch0006: 0001-Use-g-warn-error.patch
Patch0007: 0002-Update-dependencies.patch
# Upstream patches to add binding for virConnectGetAllDomainStats.
Patch0008: 0003-Add-a-binding-for-virConnectGetAllDomainStats-RHBZ-1.patch
Patch0009: 0004-examples-Print-more-stats-in-the-get_all_domain_stat.patch
Patch0010: 0005-Change-binding-of-virConnectGetAllDomainStats-to-ret.patch
# Upstream patch to use -safe-string.
Patch0011: 0001-Use-safe-string-and-fix-the-library.patch
BuildRequires: ocaml >= 3.10.0 ocaml-ocamldoc ocaml-findlib-devel BuildRequires: ocaml >= 3.10.0 ocaml-ocamldoc ocaml-findlib-devel
BuildRequires: libvirt-devel >= 0.2.1 perl-interpreter gawk BuildRequires: libvirt-devel >= 0.2.1 perl-interpreter gawk make
%description %description
OCaml bindings for libvirt, allowing you to write OCaml programs and scripts which control virtualisation features. OCaml bindings for libvirt, allowing you to write OCaml programs and scripts which control virtualisation features.
@ -78,6 +62,10 @@ make install-opt
%changelog %changelog
* Tue Jan 20 2022 yangping <yangping69@huawei.com> - 0.6.1.5-1
- Update to 0.6.1.5
* Tue Feb 18 2020 chenli <chenli147@huawei.com> - 0.6.1.4-30 * Tue Feb 18 2020 chenli <chenli147@huawei.com> - 0.6.1.4-30
- Init Package. - Init Package.