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.
23 open Opt_gettext.Gettext
29 module C = Libvirt.Connect
30 module D = Libvirt.Domain
31 module N = Libvirt.Network
33 let rcfile = ".virt-toprc"
35 (* Hooks for CSV support (see [opt_csv.ml]). *)
36 let csv_start : (string -> unit) ref =
38 fun _ -> failwith (s_"virt-top was compiled without support for CSV files")
41 (* Hook for calendar support (see [opt_calendar.ml]). *)
42 let parse_date_time : (string -> float) ref =
45 failwith (s_"virt-top was compiled without support for dates and times")
49 type init_file = NoInitFile | DefaultInitFile | InitFile of string
53 let delay = ref 3000 (* milliseconds *)
54 let historical_cpu_delay = ref 20 (* secs *)
55 let iterations = ref (-1)
56 let end_time = ref None
57 let batch_mode = ref false
58 let secure_mode = ref false
59 let sort_order = ref Processor
60 let display_mode = ref TaskDisplay
62 let debug_file = ref ""
63 let csv_enabled = ref false
64 let csv_cpu = ref true
65 let csv_mem = ref true
66 let csv_block = ref true
67 let csv_net = ref true
68 let init_file = ref DefaultInitFile
69 let script_mode = ref false
70 let stream_mode = ref false
71 let block_in_bytes = ref false
73 (* Function to read command line arguments and go into curses mode. *)
75 (* Read command line arguments. *)
76 let rec set_delay newdelay =
77 if newdelay <= 0. then
78 failwith (s_"-d: cannot set a negative delay");
79 delay := int_of_float (newdelay *. 1000.)
80 and set_uri = function "" -> uri := None | u -> uri := Some u
81 and set_sort order = sort_order := sort_order_of_cli order
82 and set_pcpu_mode () = display_mode := PCPUDisplay
83 and set_net_mode () = display_mode := NetDisplay
84 and set_block_mode () = display_mode := BlockDisplay
85 and set_csv filename =
86 (!csv_start) filename;
88 and no_init_file () = init_file := NoInitFile
89 and set_init_file filename = init_file := InitFile filename
90 and set_end_time time = end_time := Some ((!parse_date_time) time)
91 and display_version () =
92 printf "virt-top %s ocaml-libvirt %s\n"
93 Version.version Libvirt_version.version;
96 let argspec = Arg.align [
97 "-1", Arg.Unit set_pcpu_mode,
98 " " ^ s_"Start by displaying pCPUs (default: tasks)";
99 "-2", Arg.Unit set_net_mode,
100 " " ^ s_"Start by displaying network interfaces";
101 "-3", Arg.Unit set_block_mode,
102 " " ^ s_"Start by displaying block devices";
103 "-b", Arg.Set batch_mode,
104 " " ^ s_"Batch mode";
105 "-c", Arg.String set_uri,
106 "uri " ^ s_"Connect to libvirt URI";
107 "--connect", Arg.String set_uri,
108 "uri " ^ s_"Connect to libvirt URI";
109 "--csv", Arg.String set_csv,
110 "file " ^ s_"Log statistics to CSV file";
111 "--no-csv-cpu", Arg.Clear csv_cpu,
112 " " ^ s_"Disable CPU stats in CSV";
113 "--no-csv-mem", Arg.Clear csv_mem,
114 " " ^ s_"Disable memory stats in CSV";
115 "--no-csv-block", Arg.Clear csv_block,
116 " " ^ s_"Disable block device stats in CSV";
117 "--no-csv-net", Arg.Clear csv_net,
118 " " ^ s_"Disable net stats in CSV";
119 "-d", Arg.Float set_delay,
120 "delay " ^ s_"Delay time interval (seconds)";
121 "--debug", Arg.Set_string debug_file,
122 "file " ^ s_"Send debug messages to file";
123 "--end-time", Arg.String set_end_time,
124 "time " ^ s_"Exit at given time";
125 "--hist-cpu", Arg.Set_int historical_cpu_delay,
126 "secs " ^ s_"Historical CPU delay";
127 "--init-file", Arg.String set_init_file,
128 "file " ^ s_"Set name of init file";
129 "--no-init-file", Arg.Unit no_init_file,
130 " " ^ s_"Do not read init file";
131 "-n", Arg.Set_int iterations,
132 "iterations " ^ s_"Number of iterations to run";
133 "-o", Arg.String set_sort,
134 "sort " ^ sprintf (f_"Set sort order (%s)")
135 "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq";
136 "-s", Arg.Set secure_mode,
137 " " ^ s_"Secure (\"kiosk\") mode";
138 "--script", Arg.Set script_mode,
139 " " ^ s_"Run from a script (no user interface)";
140 "--stream", Arg.Set stream_mode,
141 " " ^ s_"dump output to stdout (no userinterface)";
142 "--block-in-bytes", Arg.Set block_in_bytes,
143 " " ^ s_"show block device load in bytes rather than reqs";
144 "--version", Arg.Unit display_version,
145 " " ^ s_"Display version number and exit";
148 raise (Arg.Bad (sprintf (f_"%s: unknown parameter") str)) in
149 let usage_msg = s_"virt-top : a 'top'-like utility for virtualization
155 Arg.parse argspec anon_fun usage_msg;
157 (* Read the init file. *)
158 let try_to_read_init_file filename =
159 let config = read_config_file filename in
160 (* Replacement functions that raise better errors when
161 * parsing the init file.
163 let int_of_string s =
165 with Invalid_argument _ ->
166 failwithf (f_"%s: could not parse '%s' in init file: expecting an integer")
168 let float_of_string s =
169 try float_of_string s
170 with Invalid_argument _ ->
171 failwithf (f_"%s: could not parse '%s' in init file: expecting a number")
173 let bool_of_string s =
175 with Invalid_argument _ ->
176 failwithf (f_"%s: could not parse '%s' in init file: expecting %s")
177 filename s "true|false" in
180 | _, "display", mode -> display_mode := display_of_cli mode
181 | _, "delay", secs -> set_delay (float_of_string secs)
182 | _, "hist-cpu", secs -> historical_cpu_delay := int_of_string secs
183 | _, "iterations", n -> iterations := int_of_string n
184 | _, "sort", order -> set_sort order
185 | _, "connect", uri -> set_uri uri
186 | _, "debug", filename -> debug_file := filename
187 | _, "csv", filename -> set_csv filename
188 | _, "csv-cpu", b -> csv_cpu := bool_of_string b
189 | _, "csv-mem", b -> csv_mem := bool_of_string b
190 | _, "csv-block", b -> csv_block := bool_of_string b
191 | _, "csv-net", b -> csv_net := bool_of_string b
192 | _, "batch", b -> batch_mode := bool_of_string b
193 | _, "secure", b -> secure_mode := bool_of_string b
194 | _, "script", b -> script_mode := bool_of_string b
195 | _, "stream", b -> stream_mode := bool_of_string b
196 | _, "block-in-bytes", b -> block_in_bytes := bool_of_string b
197 | _, "end-time", t -> set_end_time t
198 | _, "overwrite-init-file", "false" -> no_init_file ()
200 eprintf (f_"%s:%d: configuration item ``%s'' ignored\n%!")
204 (match !init_file with
207 let home = try Sys.getenv "HOME" with Not_found -> "/" in
208 let filename = home // rcfile in
209 try_to_read_init_file filename
210 | InitFile filename ->
211 try_to_read_init_file filename
214 (* Connect to the hypervisor before going into curses mode, since
215 * this is the most likely thing to fail.
219 try C.connect_readonly ?name ()
221 Libvirt.Virterror err ->
222 prerr_endline (Libvirt.Virterror.to_string err);
223 (* If non-root and no explicit connection URI, print a warning. *)
224 if Unix.geteuid () <> 0 && name = None then (
225 print_endline (s_"NB: If you want to monitor a local hypervisor, you usually need to be root");
229 (* Get the node_info. This never changes, right? So we get it just once. *)
230 let node_info = C.get_node_info conn in
232 (* Hostname and libvirt library version also don't change. *)
234 try C.get_hostname conn
236 (* qemu:/// and other URIs didn't support virConnectGetHostname until
237 * libvirt 0.3.3. Before that they'd throw a virterror. *)
238 | Libvirt.Virterror _
239 | Libvirt.Not_supported "virConnectGetHostname" -> "unknown" in
241 let libvirt_version =
242 let v, _ = Libvirt.get_version () in
243 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
245 (* Open debug file if specified.
246 * NB: Do this just before jumping into curses mode.
248 (match !debug_file with
249 | "" -> (* No debug file specified, send stderr to /dev/null unless
250 * we're in script mode.
252 if not !script_mode && not !stream_mode then (
253 let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o644 in
254 Unix.dup2 fd Unix.stderr;
257 | filename -> (* Send stderr to the named file. *)
259 Unix.openfile filename [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC]
261 Unix.dup2 fd Unix.stderr;
265 (* Curses voodoo (see ncurses(3)). *)
266 if not !script_mode && not !stream_mode then (
271 let stdscr = stdscr () in
272 ignore (intrflush stdscr false);
273 ignore (keypad stdscr true);
277 (* This tuple of static information is called 'setup' in other parts
278 * of this program, and is passed to other functions such as redraw and
279 * main_loop. See [main.ml].
282 !batch_mode, !script_mode, !csv_enabled, !stream_mode, (* immutable modes *)
283 node_info, hostname, libvirt_version (* info that doesn't change *)
286 (* Sleep in seconds. *)
287 let sleep = Unix.sleep
289 (* Sleep in milliseconds. *)
291 ignore (Unix.select [] [] [] (float n /. 1000.))
293 (* The curses getstr/getnstr functions are just weird.
294 * This helper function also enables echo temporarily.
296 let get_string maxlen =
298 let str = Bytes.create maxlen in
299 (* Safe because binding calls getnstr. However the unsafe cast
300 * to string is required because ocaml-curses needs to be fixed.
302 let ok = getstr (Obj.magic str) in
306 (* Chop at first '\0'. *)
308 let i = Bytes.index str '\000' in
309 Bytes.sub_string str 0 i
311 Not_found -> Bytes.to_string str (* it is full maxlen bytes *)
315 let rec main_loop ((_, batch_mode, script_mode, csv_enabled, stream_mode, _, _, _)
317 let csv_flags = !csv_cpu, !csv_mem, !csv_block, !csv_net in
320 Csv_output.write_csv_header csv_flags !block_in_bytes;
324 let state = collect setup in
326 if !display_mode = PCPUDisplay then Some (collect_pcpu state)
328 (* Redraw display. *)
329 if not script_mode && not stream_mode then
330 Redraw.redraw !display_mode !sort_order
331 setup !block_in_bytes !historical_cpu_delay
334 (* Update CSV file. *)
336 Csv_output.append_csv setup csv_flags !block_in_bytes state;
338 (* Append to stream output file. *)
340 Stream_output.append_stream setup !block_in_bytes state;
342 (* Clear up unused virDomainPtr objects. *)
345 (* Max iterations? *)
346 if !iterations >= 0 then (
348 if !iterations = 0 then quit := true
351 (* End time? We might need to adjust the precise delay down if
352 * the delay would be longer than the end time (RHBZ#637964). Note
353 * 'delay' is in milliseconds.
358 (* No --end-time option, so use the current delay. *)
361 let delay_secs = float !delay /. 1000. in
362 if end_time <= state.rd_time +. delay_secs then (
364 let delay = int_of_float (1000. *. (end_time -. state.rd_time)) in
365 if delay >= 0 then delay else 0
368 (*eprintf "adjusted delay = %d\n%!" delay;*)
370 (* Get next key. This does the sleep. *)
371 if not batch_mode && not script_mode && not stream_mode then
372 get_key_press setup delay
374 (* Batch mode, script mode, stream mode. We didn't call
375 * get_key_press, so we didn't sleep. Sleep now, unless we are
378 if not !quit || !end_time <> None then
383 and get_key_press setup delay =
384 (* Read the next key, waiting up to 'delay' milliseconds. *)
387 timeout (-1); (* Reset to blocking mode. *)
389 if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
391 if k = Char.code 'q' then quit := true
392 else if k = Char.code 'h' then show_help setup
393 else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
394 else if k = Char.code 'M' then sort_order := Memory
395 else if k = Char.code 'P' then sort_order := Processor
396 else if k = Char.code 'T' then sort_order := Time
397 else if k = Char.code 'N' then sort_order := DomainID
398 else if k = Char.code 'F' then change_sort_order ()
399 else if k = Char.code '0' then set_tasks_display ()
400 else if k = Char.code '1' then toggle_pcpu_display ()
401 else if k = Char.code '2' then toggle_net_display ()
402 else if k = Char.code '3' then toggle_block_display ()
403 else if k = Char.code 'W' then write_init_file ()
404 else if k = Char.code 'B' then toggle_block_in_bytes_mode ()
405 else unknown_command k
408 and change_delay () =
410 (sprintf (f_"Change delay from %.1f to: ") (float !delay /. 1000.));
411 let str = get_string 16 in
412 (* Try to parse the number. *)
415 let newdelay = float_of_string str in
416 if newdelay <= 0. then (
417 print_msg (s_"Delay must be > 0"); true
419 delay := int_of_float (newdelay *. 1000.); false
423 print_msg (s_"Not a valid number"); true in
425 sleep (if error then 2 else 1)
427 and change_sort_order () =
429 let lines, cols = get_size () in
431 mvaddstr top_lineno 0 (s_"Set sort order for main display");
432 mvaddstr summary_lineno 0 (s_"Type key or use up and down cursor keys.");
435 mvaddstr header_lineno 0 (pad cols "KEY Sort field");
438 let accelerator_key = function
439 | Memory -> "(key: M)"
440 | Processor -> "(key: P)"
442 | DomainID -> "(key: N)"
443 | _ -> (* all others have to be changed from here *) ""
446 let rec key_of_int = function
447 | i when i < 10 -> Char.chr (i + Char.code '0')
448 | i when i < 20 -> Char.chr (i + Char.code 'a')
450 and int_of_key = function
451 | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
452 | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
453 | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
457 (* Display possible sort fields. *)
458 let selected_index = ref 0 in
461 let selected = !sort_order = ord in
462 if selected then selected_index := i;
463 mvaddstr (domains_lineno+i) 0
464 (sprintf " %c %s %s %s"
465 (key_of_int i) (if selected then "*" else " ")
466 (printable_sort_order ord)
467 (accelerator_key ord))
470 move message_lineno 0;
473 if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
474 let new_order, loop =
475 (* Redraw the display. *)
476 if k = 12 (* ^L *) then None, true
477 (* Make the UP and DOWN arrow keys do something useful. *)
478 else if k = Key.up then (
479 if !selected_index > 0 then
480 Some (List.nth all_sort_fields (!selected_index-1)), true
484 else if k = Key.down then (
485 if !selected_index < List.length all_sort_fields - 1 then
486 Some (List.nth all_sort_fields (!selected_index+1)), true
490 (* Also understand the regular accelerator keys. *)
491 else if k = Char.code 'M' then
493 else if k = Char.code 'P' then
494 Some Processor, false
495 else if k = Char.code 'T' then
497 else if k = Char.code 'N' then
500 (* It's one of the KEYs. *)
501 let i = int_of_key k in
502 if i >= 0 && i < List.length all_sort_fields then
503 Some (List.nth all_sort_fields i), false
508 (match new_order with
511 sort_order := new_order;
512 print_msg (sprintf "Sort order changed to: %s"
513 (printable_sort_order new_order));
520 if loop then change_sort_order ()
523 (* Note: We need to clear_pcpu_display_data every time
524 * we _leave_ PCPUDisplay mode.
526 and set_tasks_display () = (* key 0 *)
527 if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
528 display_mode := TaskDisplay
530 and toggle_pcpu_display () = (* key 1 *)
532 match !display_mode with
533 | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
534 | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
536 and toggle_net_display () = (* key 2 *)
538 match !display_mode with
539 | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
540 | TaskDisplay | BlockDisplay -> NetDisplay
541 | NetDisplay -> TaskDisplay
543 and toggle_block_display () = (* key 3 *)
545 match !display_mode with
546 | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
547 | TaskDisplay | NetDisplay -> BlockDisplay
548 | BlockDisplay -> TaskDisplay
550 and toggle_block_in_bytes_mode () = (* key B *)
552 match !block_in_bytes with
556 (* Write an init file. *)
557 and write_init_file () =
558 match !init_file with
559 | NoInitFile -> () (* Do nothing if --no-init-file *)
561 let home = try Sys.getenv "HOME" with Not_found -> "/" in
562 let filename = home // rcfile in
563 _write_init_file filename
564 | InitFile filename ->
565 _write_init_file filename
567 and _write_init_file filename =
569 (* Create the new file as filename.new. *)
570 let chan = open_out (filename ^ ".new") in
572 let time = Unix.gettimeofday () in
573 let tm = Unix.localtime time in
574 let printable_date_time =
575 sprintf "%04d-%02d-%02d %02d:%02d:%02d"
576 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon+1) tm.Unix.tm_mday
577 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
580 let uid = Unix.geteuid () in
581 (Unix.getpwuid uid).Unix.pw_name
583 Not_found -> "unknown" in
586 let nl () = fp chan "\n" in
587 let () = fp chan (f_"# %s virt-top configuration file\n") rcfile in
588 let () = fp chan (f_"# generated on %s by %s\n") printable_date_time username in
590 fp chan "display %s\n" (cli_of_display !display_mode);
591 fp chan "delay %g\n" (float !delay /. 1000.);
592 fp chan "hist-cpu %d\n" !historical_cpu_delay;
593 if !iterations <> -1 then fp chan "iterations %d\n" !iterations;
594 fp chan "sort %s\n" (cli_of_sort_order !sort_order);
597 | Some uri -> fp chan "connect %s\n" uri
599 if !batch_mode = true then fp chan "batch true\n";
600 if !secure_mode = true then fp chan "secure true\n";
602 output_string chan (s_"# To send debug and error messages to a file, uncomment next line\n");
603 fp chan "#debug virt-top.out\n";
605 output_string chan (s_"# Enable CSV output to the named file\n");
606 fp chan "#csv virt-top.csv\n";
608 output_string chan (s_"# To protect this file from being overwritten, uncomment next line\n");
609 fp chan "#overwrite-init-file false\n";
613 (* If the file exists, rename it as filename.old. *)
614 (try Unix.rename filename (filename ^ ".old")
615 with Unix.Unix_error _ -> ());
617 (* Rename filename.new to filename. *)
618 Unix.rename (filename ^ ".new") filename;
620 print_msg (sprintf (f_"Wrote settings to %s") filename);
625 print_msg (s_"Error" ^ ": " ^ err);
627 | Unix.Unix_error (err, fn, str) ->
628 print_msg (s_"Error" ^ ": " ^
629 (Unix.error_message err) ^ " " ^ fn ^ " " ^ str);
633 and show_help (_, _, _, _, _, _, hostname,
634 (libvirt_major, libvirt_minor, libvirt_release)) =
637 (* Get the screen/window size. *)
638 let lines, cols = get_size () in
640 (* Banner at the top of the screen. *)
642 sprintf (f_"virt-top %s ocaml-libvirt %s libvirt %d.%d.%d by Red Hat")
644 Libvirt_version.version
645 libvirt_major libvirt_minor libvirt_release in
646 let banner = pad cols banner in
654 (f_"Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s")
655 (float !delay /. 1000.)
656 (if !batch_mode then s_"On" else s_"Off")
657 (if !secure_mode then s_"On" else s_"Off")
658 (printable_sort_order !sort_order));
661 (f_"Connect: %s; Hostname: %s")
662 (match !uri with None -> s_"default" | Some s -> s)
665 (* Misc keys on left. *)
666 let banner = pad 38 (s_"MAIN KEYS") in
668 mvaddstr header_lineno 1 banner;
672 let lineno = ref domains_lineno in
673 fun () -> let i = !lineno in incr lineno; i
675 let key keys description =
676 let lineno = get_lineno () in
677 move lineno 1; attron A.bold; addstr keys; attroff A.bold;
678 move lineno 10; addstr description
680 key "space ^L" (s_"Update display");
682 key "d s" (s_"Set update interval");
684 key "B" (s_"toggle block info req/bytes");
687 ignore (get_lineno ());
688 let banner = pad 38 (s_"SORTING") in
690 mvaddstr (get_lineno ()) 1 banner;
693 key "P" (s_"Sort by %CPU");
694 key "M" (s_"Sort by %MEM");
695 key "T" (s_"Sort by TIME");
696 key "N" (s_"Sort by ID");
697 key "F" (s_"Select sort field");
699 (* Display modes on right. *)
700 let banner = pad 39 (s_"DISPLAY MODES") in
702 mvaddstr header_lineno 40 banner;
706 let lineno = ref domains_lineno in
707 fun () -> let i = !lineno in incr lineno; i
709 let key keys description =
710 let lineno = get_lineno () in
711 move lineno 40; attron A.bold; addstr keys; attroff A.bold;
712 move lineno 49; addstr description
714 key "0" (s_"Domains display");
715 key "1" (s_"Toggle physical CPUs");
716 key "2" (s_"Toggle network interfaces");
717 key "3" (s_"Toggle block devices");
719 (* Update screen and wait for key press. *)
721 (s_"More help in virt-top(1) man page. Press any key to return.");
725 and unknown_command k =
726 print_msg (s_"Unknown command - try 'h' for help");