Fixes for safe-string and linking.

This commit is contained in:
Richard W.M. Jones 2017-11-18 12:03:50 +00:00
parent 0c60431d40
commit a6f3e36166
20 changed files with 187 additions and 105 deletions

View File

@ -1,7 +1,7 @@
From 0e47961395eec78b1ee9f6ae48520f1d95d84fdf Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 2 Aug 2014 17:37:21 +0100
Subject: [PATCH 01/17] Disable warning about immutable strings (for OCaml
Subject: [PATCH 01/19] Disable warning about immutable strings (for OCaml
4.02).
---
@ -46,5 +46,5 @@ index 5aa0c35..98e6647 100755
BYTE_TARGETS := virt-top
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 6ea4275b0d9f6d40b8d4a35f78928e71d830d721 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 21 Feb 2015 17:27:59 +0000
Subject: [PATCH 02/17] Move upstream translations from Tranifex to Zanata.
Subject: [PATCH 02/19] Move upstream translations from Tranifex to Zanata.
This is at the request of the Fedora localization team.
For further information see:
@ -163,5 +163,5 @@ index 0000000..64810f9
+
+</config>
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From defe5bdd4a32e0206a786d279e0f9cfc238e5e17 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 21 Feb 2015 17:29:16 +0000
Subject: [PATCH 03/17] Update translations from Zanata.
Subject: [PATCH 03/19] Update translations from Zanata.
---
po/LINGUAS | 12 +-
@ -4184,5 +4184,5 @@ index 9729fc3..dcf0de0 100644
#: ../virt-top/virt_top.ml:1506
msgid "# %s virt-top configuration file\\n"
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 4a2d0ccd91f07d0a2009e8553a29fcf4cf752ba3 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 4 Jan 2016 11:48:40 -0500
Subject: [PATCH 04/17] build: Add -g flag to ocamlopt.
Subject: [PATCH 04/19] build: Add -g flag to ocamlopt.
Modern ocamlopt supports the -g flag fine (very old versions did not).
---
@ -22,5 +22,5 @@ index 98e6647..e149b26 100755
BYTE_TARGETS := virt-top
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From b7c3ef13cbd9c9cd49005a32ffb70faf6f5bbe8c Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 31 Oct 2016 12:01:40 +0000
Subject: [PATCH 05/17] Rename source directory and files.
Subject: [PATCH 05/19] Rename source directory and files.
This renames the source directory from virt-top to src/ and removes
the unnecessary virt_top_* prefix from many source files.
@ -715,5 +715,5 @@ index 46099b7..0000000
-virt_top_xml.cmo: virt_top_gettext.cmo virt_top.cmi
-virt_top_xml.cmx: virt_top_gettext.cmx virt_top.cmx
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 5500a027ad231eb5bb16e36efee72b48cfac9528 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:21:48 +0100
Subject: [PATCH 06/17] Enable same warnings as libguestfs.
Subject: [PATCH 06/19] Enable same warnings as libguestfs.
In particular 'warning 3' was still enabled before, meaning that the
code would fail with newer OCaml compilers:
@ -30,5 +30,5 @@ index d29f2e8..d744fd7 100755
OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 8cd690d0b8a5343d8731145b95931ec7aaa2db35 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:25:19 +0100
Subject: [PATCH 07/17] Remove +x (executable) permission on several source
Subject: [PATCH 07/19] Remove +x (executable) permission on several source
files.
Not sure why it was there, but it was incorrect.
@ -44,5 +44,5 @@ diff --git a/src/virt-top.pod b/src/virt-top.pod
old mode 100755
new mode 100644
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From cc9f1f9d8f17e8ac5a6a73af830c132d916fd6e0 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:30:01 +0100
Subject: [PATCH 08/17] Refresh HACKING file.
Subject: [PATCH 08/19] Refresh HACKING file.
Fixes commit b7c3ef13cbd9c9cd49005a32ffb70faf6f5bbe8c.
---
@ -91,5 +91,5 @@ index bce40a9..3cd266b 100644
- virt-top.1
- virt-top.txt
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 1b4980da40000a34ec987f83824dd69454c4e8e4 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:33:22 +0100
Subject: [PATCH 09/17] Fix po/POTFILES for new location of source files.
Subject: [PATCH 09/19] Fix po/POTFILES for new location of source files.
Fixes commit b7c3ef13cbd9c9cd49005a32ffb70faf6f5bbe8c.
---
@ -30,5 +30,5 @@ index 55bb82d..70d62d5 100644
+../src/utils.ml
+../src/version.ml
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 0b6f6d45d50174e27f9a425f67bb1a6045a8e58c Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:34:20 +0100
Subject: [PATCH 10/17] Update PO files.
Subject: [PATCH 10/19] Update PO files.
---
po/as.po | 227 +++++++++++++++++++++++++++++--------------------------
@ -14275,5 +14275,5 @@ index dcf0de0..4df1241 100644
msgstr ""
+
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From effd1ec5897a2cac6e897ae7bce72f6b1e617b90 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 12:41:21 +0100
Subject: [PATCH 11/17] Remove support for OCaml Calendar v1.
Subject: [PATCH 11/19] Remove support for OCaml Calendar v1.
Calendar v2 was released in 2008 (9 years ago!), thus remove support
for v1.
@ -199,5 +199,5 @@ index 2c459fe..0000000
- *)
- Calendar.to_unixfloat cal
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 3e9ed9c0fe49c3d4e4a8e467d521f676769c485a Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 13:06:18 +0100
Subject: [PATCH 12/17] src: Fix some comments which referred to the old
Subject: [PATCH 12/19] src: Fix some comments which referred to the old
filenames.
Fixes commit b7c3ef13cbd9c9cd49005a32ffb70faf6f5bbe8c.
@ -72,5 +72,5 @@ index 3ad0718..b0953dd 100644
type setup =
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 90d14bc151e488972d33eefaac2242d9a6e07578 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 15:29:23 +0100
Subject: [PATCH 13/17] Split up huge Top module into smaller modules.
Subject: [PATCH 13/19] Split up huge Top module into smaller modules.
This change is hopefully pure refactoring, splitting up the very large
and highly interlinked module into more manageable modules with
@ -11,7 +11,7 @@ well-defined (or at least *better*-defined) interfaces between them.
po/POTFILES | 6 +
src/.depend | 36 +-
src/Makefile.in | 6 +
src/README | 38 +-
src/README | 36 +-
src/collect.ml | 455 ++++++++++++++++++++
src/collect.mli | 86 ++++
src/csv_output.ml | 118 +++++
@ -30,7 +30,7 @@ well-defined (or at least *better*-defined) interfaces between them.
src/types.mli | 49 +++
src/utils.ml | 65 ---
src/utils.mli | 9 -
23 files changed, 1719 insertions(+), 1223 deletions(-)
23 files changed, 1718 insertions(+), 1222 deletions(-)
create mode 100644 src/collect.ml
create mode 100644 src/collect.mli
create mode 100644 src/csv_output.ml
@ -167,8 +167,10 @@ index 8aa2348..1fd4be3 100644
String functions and other small utility functions. This is
included directly into virt_top.ml.
- top.mli, top.ml
+ types.mli, types.ml
+
- This is the virt-top program.
+ Various internally used types and functions operating on those
+ types.
+
@ -181,27 +183,24 @@ index 8aa2348..1fd4be3 100644
+ Various useful functions for drawing to the curses screen.
+
+ redraw.mli, redraw.ml
+
- The two interesting functions are called 'collect' and 'redraw'.
+ Redraw the main display.
+
- 'collect' collects all the information about domains, etc.
+ csv_output.mli, csv_output.ml
+
- 'redraw' updates the display on each frame.
+ Functions which implement --csv mode.
+
+ stream_output.mli, stream_output.ml
+
+ Functions which implement --stream mode.
+
top.mli, top.ml
+ top.mli, top.ml
+
+ This is the virt-top program.
This is the virt-top program.
- The two interesting functions are called 'collect' and 'redraw'.
-
- 'collect' collects all the information about domains, etc.
-
- 'redraw' updates the display on each frame.
-
- Another interesting function is 'start_up' which handles all
- start-up stuff, eg. command line arguments, connecting to the
- hypervisor, enabling curses.
@ -3270,5 +3269,5 @@ index 5b71b31..6e81215 100644
-val sum_interface_stats : interface_stats list -> interface_stats
-val diff_interface_stats : interface_stats -> interface_stats -> interface_stats
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 431dbd98bad6e3635b4d0885bf33dd3e759ca35d Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Mon, 27 Mar 2017 21:22:52 +0100
Subject: [PATCH 14/17] Move block_in_bytes entirely to the presentation layer.
Subject: [PATCH 14/19] Move block_in_bytes entirely to the presentation layer.
Simplifies and updates commit dbef8dd3bf00417e75a12c851b053e49c9e1a79e.
---
@ -207,5 +207,5 @@ index 204f3b6..e2a93d6 100644
(* Append to stream output file. *)
if stream_mode then
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 4f3794d5718249238a74b614a6b486465bc4315d Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 13:09:54 +0100
Subject: [PATCH 15/17] Remove unused variable is_calendar2.
Subject: [PATCH 15/19] Remove unused variable is_calendar2.
Fixes commit effd1ec5897a2cac6e897ae7bce72f6b1e617b90.
---
@ -21,5 +21,5 @@ index 64f431e..6a13bef 100644
OCAMLCPACKAGES := -package unix,extlib,curses,str,libvirt
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From c513d05fd4e85953701b1023bef71af62613cf79 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 13:30:07 +0100
Subject: [PATCH 16/17] Use virConnectGetAllDomainStats API to collect domain
Subject: [PATCH 16/19] Use virConnectGetAllDomainStats API to collect domain
stats (RHBZ#1422795).
This is much faster than using the basic libvirt APIs to collect
@ -10,11 +10,11 @@ stats for each domain individually.
Note this will not work unless you have the latest ocaml-libvirt
package which includes this new API binding.
---
src/collect.ml | 242 +++++++++++++++++++++++++++++++++++++++++---------------
src/collect.ml | 252 +++++++++++++++++++++++++++++++++++++++++---------------
src/collect.mli | 1 +
src/utils.ml | 6 ++
src/utils.mli | 3 +
4 files changed, 190 insertions(+), 62 deletions(-)
4 files changed, 195 insertions(+), 67 deletions(-)
diff --git a/src/collect.ml b/src/collect.ml
index 448ce8c..a1e50a1 100644
@ -61,6 +61,60 @@ index 448ce8c..a1e50a1 100644
- let dom = D.lookup_by_id conn id in
- let name = D.get_name dom in
- let blkdevs, netifs = get_devices id dom in
-
- (* Get current CPU, block and network stats. *)
- let info = D.get_info dom in
- let block_stats =
- try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs
- with
- | Libvirt.Not_supported "virDomainBlockStats"
- | Libvirt.Virterror _ -> [] in
- let interface_stats =
- try List.map (fun dev -> dev, D.interface_stats dom dev) netifs
- with
- | Libvirt.Not_supported "virDomainInterfaceStats"
- | Libvirt.Virterror _ -> [] in
-
- let prev_info, prev_block_stats, prev_interface_stats =
- try
- let prev_info, prev_block_stats, prev_interface_stats =
- Hashtbl.find last_info id in
- Some prev_info, prev_block_stats, prev_interface_stats
- with Not_found -> None, [], [] in
-
- Some (name,
- Active {
- rd_domid = id; rd_dom = dom; rd_info = info;
- rd_block_stats = block_stats;
- rd_interface_stats = interface_stats;
- rd_prev_info = prev_info;
- rd_prev_block_stats = prev_block_stats;
- rd_prev_interface_stats = prev_interface_stats;
- rd_cpu_time = 0.; rd_percent_cpu = 0.;
- rd_mem_bytes = 0L; rd_mem_percent = 0L;
- rd_block_rd_reqs = None; rd_block_wr_reqs = None;
- rd_block_rd_bytes = None; rd_block_wr_bytes = None;
- rd_net_rx_bytes = None; rd_net_tx_bytes = None;
- })
- with
- Libvirt.Virterror _ -> None (* ignore transient error *)
- ) ids in
-
- (* Inactive domains. *)
- let doms_inactive =
- try
- let n = C.num_of_defined_domains conn in
- let names =
- if n > 0 then Array.to_list (C.list_defined_domains conn n)
- else [] in
- List.map (fun name -> name, Inactive) names
- with
- (* Ignore transient errors, in particular errors from
- * num_of_defined_domains if it cannot contact xend.
- *)
- | Libvirt.Virterror _ -> [] in
-
- doms @ doms_inactive in
+ let doms = D.get_all_domain_stats conn what who in
+ let doms = Array.to_list doms in
+ List.map (
@ -92,52 +146,17 @@ index 448ce8c..a1e50a1 100644
+ | Some (D.TypedFieldUInt64 i) -> Some i
+ | _ -> default
+ in
- (* Get current CPU, block and network stats. *)
- let info = D.get_info dom in
- let block_stats =
- try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs
- with
- | Libvirt.Not_supported "virDomainBlockStats"
- | Libvirt.Virterror _ -> [] in
- let interface_stats =
- try List.map (fun dev -> dev, D.interface_stats dom dev) netifs
- with
- | Libvirt.Not_supported "virDomainInterfaceStats"
- | Libvirt.Virterror _ -> [] in
+
+ let dom = D.lookup_by_uuid conn uuid in
+ let id = D.get_id dom in
+ let name = D.get_name dom in
+ let state = get_param_int "state.state" None in
- let prev_info, prev_block_stats, prev_interface_stats =
- try
- let prev_info, prev_block_stats, prev_interface_stats =
- Hashtbl.find last_info id in
- Some prev_info, prev_block_stats, prev_interface_stats
- with Not_found -> None, [], [] in
+
+ if state = Some 5 (* VIR_DOMAIN_SHUTOFF *) then
+ (name, Inactive)
+ else (
+ (* Active domain. *)
- Some (name,
- Active {
- rd_domid = id; rd_dom = dom; rd_info = info;
- rd_block_stats = block_stats;
- rd_interface_stats = interface_stats;
- rd_prev_info = prev_info;
- rd_prev_block_stats = prev_block_stats;
- rd_prev_interface_stats = prev_interface_stats;
- rd_cpu_time = 0.; rd_percent_cpu = 0.;
- rd_mem_bytes = 0L; rd_mem_percent = 0L;
- rd_block_rd_reqs = None; rd_block_wr_reqs = None;
- rd_block_rd_bytes = None; rd_block_wr_bytes = None;
- rd_net_rx_bytes = None; rd_net_tx_bytes = None;
- })
- with
- Libvirt.Virterror _ -> None (* ignore transient error *)
- ) ids in
+
+ (* Synthesize a D.info struct out of the data we have
+ * from virConnectGetAllDomainStats. Doing this is an
+ * artifact from the old APIs we used to use to fetch
@ -175,20 +194,7 @@ index 448ce8c..a1e50a1 100644
+ nr_virt_cpu = nr_virt_cpu;
+ cpu_time = cpu_time
+ } in
- (* Inactive domains. *)
- let doms_inactive =
- try
- let n = C.num_of_defined_domains conn in
- let names =
- if n > 0 then Array.to_list (C.list_defined_domains conn n)
- else [] in
- List.map (fun name -> name, Inactive) names
- with
- (* Ignore transient errors, in particular errors from
- * num_of_defined_domains if it cannot contact xend.
- *)
- | Libvirt.Virterror _ -> [] in
+
+ let nr_block_devs =
+ match get_param_int "block.count" None with
+ | None -> 0
@ -217,8 +223,7 @@ index 448ce8c..a1e50a1 100644
+ errs = 0_L
+ }
+ ) (range 0 (nr_block_devs-1)) in
- doms @ doms_inactive in
+
+ let nr_interface_devs =
+ match get_param_int "net.count" None with
+ | None -> 0
@ -339,5 +344,5 @@ index 6e81215..3c966f8 100644
* If the config file is missing this returns an empty list.
*)
--
2.9.3
2.13.1

View File

@ -1,7 +1,7 @@
From 20c078bead38fd9e413660d4d8fdc3fd4f76edf7 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 28 Mar 2017 14:36:07 +0100
Subject: [PATCH 17/17] chmod -x COPYING* files.
Subject: [PATCH 17/19] chmod -x COPYING* files.
---
COPYING | 0
@ -17,5 +17,5 @@ diff --git a/COPYING.LIB b/COPYING.LIB
old mode 100755
new mode 100644
--
2.9.3
2.13.1

View File

@ -0,0 +1,42 @@
From a58c90e04e5b54f8c6a67b09a93cfc33402cf398 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 18 Nov 2017 12:01:34 +0000
Subject: [PATCH 18/19] Fixes for -safe-string in OCaml 4.06.
---
src/top.ml | 13 ++++++++-----
1 file changed, 8 insertions(+), 5 deletions(-)
diff --git a/src/top.ml b/src/top.ml
index e2a93d6..d4f7697 100644
--- a/src/top.ml
+++ b/src/top.ml
@@ -296,17 +296,20 @@ let millisleep n =
*)
let get_string maxlen =
ignore (echo ());
- let str = String.create maxlen in
- let ok = getstr str in (* Safe because binding calls getnstr. *)
+ let str = Bytes.create maxlen in
+ (* Safe because binding calls getnstr. However the unsafe cast
+ * to string is required because ocaml-curses needs to be fixed.
+ *)
+ let ok = getstr (Obj.magic str) in
ignore (noecho ());
if not ok then ""
else (
(* Chop at first '\0'. *)
try
- let i = String.index str '\000' in
- String.sub str 0 i
+ let i = Bytes.index str '\000' in
+ Bytes.sub_string str 0 i
with
- Not_found -> str (* it is full maxlen bytes *)
+ Not_found -> Bytes.to_string str (* it is full maxlen bytes *)
)
(* Main loop. *)
--
2.13.1

View File

@ -0,0 +1,32 @@
From 18a751d8c26548bb090ff05e30ccda3092e3373b Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Sat, 18 Nov 2017 12:01:49 +0000
Subject: [PATCH 19/19] Link with -fPIC runtime.
---
src/Makefile.in | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/src/Makefile.in b/src/Makefile.in
index 6a13bef..03c6362 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -84,11 +84,14 @@ all: $(BYTE_TARGETS)
opt: $(OPT_TARGETS)
virt-top: $(OBJS)
- ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) -o $@ $^
+ ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ -runtime-variant _pic \
+ -o $@ $^
virt-top.opt: $(XOBJS)
ocamlfind ocamlopt \
$(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ -runtime-variant _pic \
-o $@ $^
# Manual page.
--
2.13.1

View File

@ -36,6 +36,8 @@ Patch0014: 0014-Move-block_in_bytes-entirely-to-the-presentation-lay.patch
Patch0015: 0015-Remove-unused-variable-is_calendar2.patch
Patch0016: 0016-Use-virConnectGetAllDomainStats-API-to-collect-domai.patch
Patch0017: 0017-chmod-x-COPYING-files.patch
Patch0018: 0018-Fixes-for-safe-string-in-OCaml-4.06.patch
Patch0019: 0019-Link-with-fPIC-runtime.patch
# Update configure for aarch64 (bz #926701)
Patch9999: virt-top-aarch64.patch
@ -102,6 +104,8 @@ different virtualization systems.
%patch0015 -p1
%patch0016 -p1
%patch0017 -p1
%patch0018 -p1
%patch0019 -p1
# Update configure for aarch64 (bz #926701)
%patch9999 -p1