1 (* 'top'-like tool for libvirt domains.
2 (C) Copyright 2007-2017 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 open Opt_gettext.Gettext
23 module C = Libvirt.Connect
24 module D = Libvirt.Domain
26 (* XXX We should get rid of this type. *)
28 Libvirt.ro C.t (* connection *)
29 * bool * bool * bool * bool (* batch, script, csv, stream mode *)
30 * C.node_info (* node_info *)
31 * string (* hostname *)
32 * (int * int * int) (* libvirt version *)
36 | DomainID | DomainName | Processor | Memory | Time
37 | NetRX | NetTX | BlockRdRq | BlockWrRq
38 let all_sort_fields = [
39 DomainID; DomainName; Processor; Memory; Time;
40 NetRX; NetTX; BlockRdRq; BlockWrRq
42 let printable_sort_order = function
43 | Processor -> s_"%CPU"
45 | Time -> s_"TIME (CPU time)"
46 | DomainID -> s_"Domain ID"
47 | DomainName -> s_"Domain name"
48 | NetRX -> s_"Net RX bytes"
49 | NetTX -> s_"Net TX bytes"
50 | BlockRdRq -> s_"Block read reqs"
51 | BlockWrRq -> s_"Block write reqs"
52 let sort_order_of_cli = function
53 | "cpu" | "processor" -> Processor
54 | "mem" | "memory" -> Memory
57 | "name" -> DomainName
58 | "netrx" -> NetRX | "nettx" -> NetTX
59 | "blockrdrq" -> BlockRdRq | "blockwrrq" -> BlockWrRq
61 failwithf (f_"%s: sort order should be: %s")
62 str "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq"
63 let cli_of_sort_order = function
68 | DomainName -> "name"
71 | BlockRdRq -> "blockrdrq"
72 | BlockWrRq -> "blockwrrq"
74 (* Current major display mode: TaskDisplay is the normal display. *)
75 type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay
77 let display_of_cli = function
78 | "task" -> TaskDisplay
79 | "pcpu" -> PCPUDisplay
80 | "block" -> BlockDisplay
83 failwithf (f_"%s: display should be %s") str "task|pcpu|block|net"
84 let cli_of_display = function
85 | TaskDisplay -> "task"
86 | PCPUDisplay -> "pcpu"
87 | BlockDisplay -> "block"
90 (* Sum Domain.block_stats structures together. Missing fields
91 * get forced to 0. Empty list returns all 0.
93 let zero_block_stats =
94 { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L }
95 let add_block_stats bs1 bs2 =
96 let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
97 { D.rd_req = add bs1.D.rd_req bs2.D.rd_req;
98 rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes;
99 wr_req = add bs1.D.wr_req bs2.D.wr_req;
100 wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes;
101 errs = add bs1.D.errs bs2.D.errs }
102 let sum_block_stats =
103 List.fold_left add_block_stats zero_block_stats
105 (* Get the difference between two block_stats structures. Missing data
106 * forces the difference to -1.
108 let diff_block_stats curr prev =
109 let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
110 { D.rd_req = sub curr.D.rd_req prev.D.rd_req;
111 rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes;
112 wr_req = sub curr.D.wr_req prev.D.wr_req;
113 wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes;
114 errs = sub curr.D.errs prev.D.errs }
116 (* Sum Domain.interface_stats structures together. Missing fields
117 * get forced to 0. Empty list returns all 0.
119 let zero_interface_stats =
120 { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L;
121 tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L }
122 let add_interface_stats is1 is2 =
123 let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
124 { D.rx_bytes = add is1.D.rx_bytes is2.D.rx_bytes;
125 rx_packets = add is1.D.rx_packets is2.D.rx_packets;
126 rx_errs = add is1.D.rx_errs is2.D.rx_errs;
127 rx_drop = add is1.D.rx_drop is2.D.rx_drop;
128 tx_bytes = add is1.D.tx_bytes is2.D.tx_bytes;
129 tx_packets = add is1.D.tx_packets is2.D.tx_packets;
130 tx_errs = add is1.D.tx_errs is2.D.tx_errs;
131 tx_drop = add is1.D.tx_drop is2.D.tx_drop }
132 let sum_interface_stats =
133 List.fold_left add_interface_stats zero_interface_stats
135 (* Get the difference between two interface_stats structures.
136 * Missing data forces the difference to -1.
138 let diff_interface_stats curr prev =
139 let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
140 { D.rx_bytes = sub curr.D.rx_bytes prev.D.rx_bytes;
141 rx_packets = sub curr.D.rx_packets prev.D.rx_packets;
142 rx_errs = sub curr.D.rx_errs prev.D.rx_errs;
143 rx_drop = sub curr.D.rx_drop prev.D.rx_drop;
144 tx_bytes = sub curr.D.tx_bytes prev.D.tx_bytes;
145 tx_packets = sub curr.D.tx_packets prev.D.tx_packets;
146 tx_errs = sub curr.D.tx_errs prev.D.tx_errs;
147 tx_drop = sub curr.D.tx_drop prev.D.tx_drop }