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.
24 open Opt_gettext.Gettext
30 module C = Libvirt.Connect
31 module D = Libvirt.Domain
32 module N = Libvirt.Network
34 let rcfile = ".virt-toprc"
36 (* Hooks for CSV support (see [opt_csv.ml]). *)
37 let csv_start : (string -> unit) ref =
39 fun _ -> failwith (s_"virt-top was compiled without support for CSV files")
42 (* Hook for calendar support (see [opt_calendar.ml]). *)
43 let parse_date_time : (string -> float) ref =
46 failwith (s_"virt-top was compiled without support for dates and times")
50 type init_file = NoInitFile | DefaultInitFile | InitFile of string
54 let delay = ref 3000 (* milliseconds *)
55 let historical_cpu_delay = ref 20 (* secs *)
56 let iterations = ref (-1)
57 let end_time = ref None
58 let batch_mode = ref false
59 let secure_mode = ref false
60 let sort_order = ref Processor
61 let display_mode = ref TaskDisplay
63 let debug_file = ref ""
64 let csv_enabled = ref false
65 let csv_cpu = ref true
66 let csv_mem = ref true
67 let csv_block = ref true
68 let csv_net = ref true
69 let init_file = ref DefaultInitFile
70 let script_mode = ref false
71 let stream_mode = ref false
72 let block_in_bytes = ref false
74 (* Function to read command line arguments and go into curses mode. *)
76 (* Read command line arguments. *)
77 let rec set_delay newdelay =
78 if newdelay <= 0. then
79 failwith (s_"-d: cannot set a negative delay");
80 delay := int_of_float (newdelay *. 1000.)
81 and set_uri = function "" -> uri := None | u -> uri := Some u
82 and set_sort order = sort_order := sort_order_of_cli order
83 and set_pcpu_mode () = display_mode := PCPUDisplay
84 and set_net_mode () = display_mode := NetDisplay
85 and set_block_mode () = display_mode := BlockDisplay
86 and set_csv filename =
87 (!csv_start) filename;
89 and no_init_file () = init_file := NoInitFile
90 and set_init_file filename = init_file := InitFile filename
91 and set_end_time time = end_time := Some ((!parse_date_time) time)
92 and display_version () =
93 printf "virt-top %s ocaml-libvirt %s\n"
94 Version.version Libvirt_version.version;
97 let argspec = Arg.align [
98 "-1", Arg.Unit set_pcpu_mode,
99 " " ^ s_"Start by displaying pCPUs (default: tasks)";
100 "-2", Arg.Unit set_net_mode,
101 " " ^ s_"Start by displaying network interfaces";
102 "-3", Arg.Unit set_block_mode,
103 " " ^ s_"Start by displaying block devices";
104 "-b", Arg.Set batch_mode,
105 " " ^ s_"Batch mode";
106 "-c", Arg.String set_uri,
107 "uri " ^ s_"Connect to libvirt URI";
108 "--connect", Arg.String set_uri,
109 "uri " ^ s_"Connect to libvirt URI";
110 "--csv", Arg.String set_csv,
111 "file " ^ s_"Log statistics to CSV file";
112 "--no-csv-cpu", Arg.Clear csv_cpu,
113 " " ^ s_"Disable CPU stats in CSV";
114 "--no-csv-mem", Arg.Clear csv_mem,
115 " " ^ s_"Disable memory stats in CSV";
116 "--no-csv-block", Arg.Clear csv_block,
117 " " ^ s_"Disable block device stats in CSV";
118 "--no-csv-net", Arg.Clear csv_net,
119 " " ^ s_"Disable net stats in CSV";
120 "-d", Arg.Float set_delay,
121 "delay " ^ s_"Delay time interval (seconds)";
122 "--debug", Arg.Set_string debug_file,
123 "file " ^ s_"Send debug messages to file";
124 "--end-time", Arg.String set_end_time,
125 "time " ^ s_"Exit at given time";
126 "--hist-cpu", Arg.Set_int historical_cpu_delay,
127 "secs " ^ s_"Historical CPU delay";
128 "--init-file", Arg.String set_init_file,
129 "file " ^ s_"Set name of init file";
130 "--no-init-file", Arg.Unit no_init_file,
131 " " ^ s_"Do not read init file";
132 "-n", Arg.Set_int iterations,
133 "iterations " ^ s_"Number of iterations to run";
134 "-o", Arg.String set_sort,
135 "sort " ^ sprintf (f_"Set sort order (%s)")
136 "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq";
137 "-s", Arg.Set secure_mode,
138 " " ^ s_"Secure (\"kiosk\") mode";
139 "--script", Arg.Set script_mode,
140 " " ^ s_"Run from a script (no user interface)";
141 "--stream", Arg.Set stream_mode,
142 " " ^ s_"dump output to stdout (no userinterface)";
143 "--block-in-bytes", Arg.Set block_in_bytes,
144 " " ^ s_"show block device load in bytes rather than reqs";
145 "--version", Arg.Unit display_version,
146 " " ^ s_"Display version number and exit";
149 raise (Arg.Bad (sprintf (f_"%s: unknown parameter") str)) in
150 let usage_msg = s_"virt-top : a 'top'-like utility for virtualization
156 Arg.parse argspec anon_fun usage_msg;
158 (* Read the init file. *)
159 let try_to_read_init_file filename =
160 let config = read_config_file filename in
161 (* Replacement functions that raise better errors when
162 * parsing the init file.
164 let int_of_string s =
166 with Invalid_argument _ ->
167 failwithf (f_"%s: could not parse '%s' in init file: expecting an integer")
169 let float_of_string s =
170 try float_of_string s
171 with Invalid_argument _ ->
172 failwithf (f_"%s: could not parse '%s' in init file: expecting a number")
174 let bool_of_string s =
176 with Invalid_argument _ ->
177 failwithf (f_"%s: could not parse '%s' in init file: expecting %s")
178 filename s "true|false" in
181 | _, "display", mode -> display_mode := display_of_cli mode
182 | _, "delay", secs -> set_delay (float_of_string secs)
183 | _, "hist-cpu", secs -> historical_cpu_delay := int_of_string secs
184 | _, "iterations", n -> iterations := int_of_string n
185 | _, "sort", order -> set_sort order
186 | _, "connect", uri -> set_uri uri
187 | _, "debug", filename -> debug_file := filename
188 | _, "csv", filename -> set_csv filename
189 | _, "csv-cpu", b -> csv_cpu := bool_of_string b
190 | _, "csv-mem", b -> csv_mem := bool_of_string b
191 | _, "csv-block", b -> csv_block := bool_of_string b
192 | _, "csv-net", b -> csv_net := bool_of_string b
193 | _, "batch", b -> batch_mode := bool_of_string b
194 | _, "secure", b -> secure_mode := bool_of_string b
195 | _, "script", b -> script_mode := bool_of_string b
196 | _, "stream", b -> stream_mode := bool_of_string b
197 | _, "block-in-bytes", b -> block_in_bytes := bool_of_string b
198 | _, "end-time", t -> set_end_time t
199 | _, "overwrite-init-file", "false" -> no_init_file ()
201 eprintf (f_"%s:%d: configuration item ``%s'' ignored\n%!")
205 (match !init_file with
208 let home = try Sys.getenv "HOME" with Not_found -> "/" in
209 let filename = home // rcfile in
210 try_to_read_init_file filename
211 | InitFile filename ->
212 try_to_read_init_file filename
215 (* Connect to the hypervisor before going into curses mode, since
216 * this is the most likely thing to fail.
220 try C.connect_readonly ?name ()
222 Libvirt.Virterror err ->
223 prerr_endline (Libvirt.Virterror.to_string err);
224 (* If non-root and no explicit connection URI, print a warning. *)
225 if Unix.geteuid () <> 0 && name = None then (
226 print_endline (s_"NB: If you want to monitor a local hypervisor, you usually need to be root");
230 (* Get the node_info. This never changes, right? So we get it just once. *)
231 let node_info = C.get_node_info conn in
233 (* Hostname and libvirt library version also don't change. *)
235 try C.get_hostname conn
237 (* qemu:/// and other URIs didn't support virConnectGetHostname until
238 * libvirt 0.3.3. Before that they'd throw a virterror. *)
239 | Libvirt.Virterror _
240 | Libvirt.Not_supported "virConnectGetHostname" -> "unknown" in
242 let libvirt_version =
243 let v, _ = Libvirt.get_version () in
244 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
246 (* Open debug file if specified.
247 * NB: Do this just before jumping into curses mode.
249 (match !debug_file with
250 | "" -> (* No debug file specified, send stderr to /dev/null unless
251 * we're in script mode.
253 if not !script_mode && not !stream_mode then (
254 let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o644 in
255 Unix.dup2 fd Unix.stderr;
258 | filename -> (* Send stderr to the named file. *)
260 Unix.openfile filename [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC]
262 Unix.dup2 fd Unix.stderr;
266 (* Curses voodoo (see ncurses(3)). *)
267 if not !script_mode && not !stream_mode then (
272 let stdscr = stdscr () in
273 ignore (intrflush stdscr false);
274 ignore (keypad stdscr true);
278 (* This tuple of static information is called 'setup' in other parts
279 * of this program, and is passed to other functions such as redraw and
280 * main_loop. See [main.ml].
283 !batch_mode, !script_mode, !csv_enabled, !stream_mode, (* immutable modes *)
284 node_info, hostname, libvirt_version (* info that doesn't change *)
287 (* Sleep in seconds. *)
288 let sleep = Unix.sleep
290 (* Sleep in milliseconds. *)
292 ignore (Unix.select [] [] [] (float n /. 1000.))
294 (* The curses getstr/getnstr functions are just weird.
295 * This helper function also enables echo temporarily.
297 let get_string maxlen =
299 let str = Bytes.create maxlen in
300 (* Safe because binding calls getnstr. However the unsafe cast
301 * to string is required because ocaml-curses needs to be fixed.
303 let ok = getstr (Obj.magic str) in
307 (* Chop at first '\0'. *)
309 let i = Bytes.index str '\000' in
310 Bytes.sub_string str 0 i
312 Not_found -> Bytes.to_string str (* it is full maxlen bytes *)
316 let rec main_loop ((_, batch_mode, script_mode, csv_enabled, stream_mode, _, _, _)
318 let csv_flags = !csv_cpu, !csv_mem, !csv_block, !csv_net in
321 Csv_output.write_csv_header csv_flags !block_in_bytes;
325 let state = collect setup in
327 if !display_mode = PCPUDisplay then Some (collect_pcpu state)
329 (* Redraw display. *)
330 if not script_mode && not stream_mode then
331 Redraw.redraw !display_mode !sort_order
332 setup !block_in_bytes !historical_cpu_delay
335 (* Update CSV file. *)
337 Csv_output.append_csv setup csv_flags !block_in_bytes state;
339 (* Append to stream output file. *)
341 Stream_output.append_stream setup !block_in_bytes state;
343 (* Clear up unused virDomainPtr objects. *)
346 (* Max iterations? *)
347 if !iterations >= 0 then (
349 if !iterations = 0 then quit := true
352 (* End time? We might need to adjust the precise delay down if
353 * the delay would be longer than the end time (RHBZ#637964). Note
354 * 'delay' is in milliseconds.
359 (* No --end-time option, so use the current delay. *)
362 let delay_secs = float !delay /. 1000. in
363 if end_time <= state.rd_time +. delay_secs then (
365 let delay = int_of_float (1000. *. (end_time -. state.rd_time)) in
366 if delay >= 0 then delay else 0
369 (*eprintf "adjusted delay = %d\n%!" delay;*)
371 (* Get next key. This does the sleep. *)
372 if not batch_mode && not script_mode && not stream_mode then
373 get_key_press setup delay
375 (* Batch mode, script mode, stream mode. We didn't call
376 * get_key_press, so we didn't sleep. Sleep now, unless we are
379 if not !quit || !end_time <> None then
384 and get_key_press setup delay =
385 (* Read the next key, waiting up to 'delay' milliseconds. *)
388 timeout (-1); (* Reset to blocking mode. *)
390 if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
392 if k = Char.code 'q' then quit := true
393 else if k = Char.code 'h' then show_help setup
394 else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
395 else if k = Char.code 'M' then sort_order := Memory
396 else if k = Char.code 'P' then sort_order := Processor
397 else if k = Char.code 'T' then sort_order := Time
398 else if k = Char.code 'N' then sort_order := DomainID
399 else if k = Char.code 'F' then change_sort_order ()
400 else if k = Char.code '0' then set_tasks_display ()
401 else if k = Char.code '1' then toggle_pcpu_display ()
402 else if k = Char.code '2' then toggle_net_display ()
403 else if k = Char.code '3' then toggle_block_display ()
404 else if k = Char.code 'W' then write_init_file ()
405 else if k = Char.code 'B' then toggle_block_in_bytes_mode ()
406 else unknown_command k
409 and change_delay () =
411 (sprintf (f_"Change delay from %.1f to: ") (float !delay /. 1000.));
412 let str = get_string 16 in
413 (* Try to parse the number. *)
416 let newdelay = float_of_string str in
417 if newdelay <= 0. then (
418 print_msg (s_"Delay must be > 0"); true
420 delay := int_of_float (newdelay *. 1000.); false
424 print_msg (s_"Not a valid number"); true in
426 sleep (if error then 2 else 1)
428 and change_sort_order () =
430 let lines, cols = get_size () in
432 mvaddstr top_lineno 0 (s_"Set sort order for main display");
433 mvaddstr summary_lineno 0 (s_"Type key or use up and down cursor keys.");
436 mvaddstr header_lineno 0 (pad cols "KEY Sort field");
439 let accelerator_key = function
440 | Memory -> "(key: M)"
441 | Processor -> "(key: P)"
443 | DomainID -> "(key: N)"
444 | _ -> (* all others have to be changed from here *) ""
447 let rec key_of_int = function
448 | i when i < 10 -> Char.chr (i + Char.code '0')
449 | i when i < 20 -> Char.chr (i + Char.code 'a')
451 and int_of_key = function
452 | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
453 | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
454 | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
458 (* Display possible sort fields. *)
459 let selected_index = ref 0 in
462 let selected = !sort_order = ord in
463 if selected then selected_index := i;
464 mvaddstr (domains_lineno+i) 0
465 (sprintf " %c %s %s %s"
466 (key_of_int i) (if selected then "*" else " ")
467 (printable_sort_order ord)
468 (accelerator_key ord))
471 move message_lineno 0;
474 if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
475 let new_order, loop =
476 (* Redraw the display. *)
477 if k = 12 (* ^L *) then None, true
478 (* Make the UP and DOWN arrow keys do something useful. *)
479 else if k = Key.up then (
480 if !selected_index > 0 then
481 Some (List.nth all_sort_fields (!selected_index-1)), true
485 else if k = Key.down then (
486 if !selected_index < List.length all_sort_fields - 1 then
487 Some (List.nth all_sort_fields (!selected_index+1)), true
491 (* Also understand the regular accelerator keys. *)
492 else if k = Char.code 'M' then
494 else if k = Char.code 'P' then
495 Some Processor, false
496 else if k = Char.code 'T' then
498 else if k = Char.code 'N' then
501 (* It's one of the KEYs. *)
502 let i = int_of_key k in
503 if i >= 0 && i < List.length all_sort_fields then
504 Some (List.nth all_sort_fields i), false
509 (match new_order with
512 sort_order := new_order;
513 print_msg (sprintf "Sort order changed to: %s"
514 (printable_sort_order new_order));
521 if loop then change_sort_order ()
524 (* Note: We need to clear_pcpu_display_data every time
525 * we _leave_ PCPUDisplay mode.
527 and set_tasks_display () = (* key 0 *)
528 if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
529 display_mode := TaskDisplay
531 and toggle_pcpu_display () = (* key 1 *)
533 match !display_mode with
534 | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
535 | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
537 and toggle_net_display () = (* key 2 *)
539 match !display_mode with
540 | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
541 | TaskDisplay | BlockDisplay -> NetDisplay
542 | NetDisplay -> TaskDisplay
544 and toggle_block_display () = (* key 3 *)
546 match !display_mode with
547 | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
548 | TaskDisplay | NetDisplay -> BlockDisplay
549 | BlockDisplay -> TaskDisplay
551 and toggle_block_in_bytes_mode () = (* key B *)
553 match !block_in_bytes with
557 (* Write an init file. *)
558 and write_init_file () =
559 match !init_file with
560 | NoInitFile -> () (* Do nothing if --no-init-file *)
562 let home = try Sys.getenv "HOME" with Not_found -> "/" in
563 let filename = home // rcfile in
564 _write_init_file filename
565 | InitFile filename ->
566 _write_init_file filename
568 and _write_init_file filename =
570 (* Create the new file as filename.new. *)
571 let chan = open_out (filename ^ ".new") in
573 let time = Unix.gettimeofday () in
574 let tm = Unix.localtime time in
575 let printable_date_time =
576 sprintf "%04d-%02d-%02d %02d:%02d:%02d"
577 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon+1) tm.Unix.tm_mday
578 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
581 let uid = Unix.geteuid () in
582 (Unix.getpwuid uid).Unix.pw_name
584 Not_found -> "unknown" in
587 let nl () = fp chan "\n" in
588 let () = fp chan (f_"# %s virt-top configuration file\n") rcfile in
589 let () = fp chan (f_"# generated on %s by %s\n") printable_date_time username in
591 fp chan "display %s\n" (cli_of_display !display_mode);
592 fp chan "delay %g\n" (float !delay /. 1000.);
593 fp chan "hist-cpu %d\n" !historical_cpu_delay;
594 if !iterations <> -1 then fp chan "iterations %d\n" !iterations;
595 fp chan "sort %s\n" (cli_of_sort_order !sort_order);
598 | Some uri -> fp chan "connect %s\n" uri
600 if !batch_mode = true then fp chan "batch true\n";
601 if !secure_mode = true then fp chan "secure true\n";
603 output_string chan (s_"# To send debug and error messages to a file, uncomment next line\n");
604 fp chan "#debug virt-top.out\n";
606 output_string chan (s_"# Enable CSV output to the named file\n");
607 fp chan "#csv virt-top.csv\n";
609 output_string chan (s_"# To protect this file from being overwritten, uncomment next line\n");
610 fp chan "#overwrite-init-file false\n";
614 (* If the file exists, rename it as filename.old. *)
615 (try Unix.rename filename (filename ^ ".old")
616 with Unix.Unix_error _ -> ());
618 (* Rename filename.new to filename. *)
619 Unix.rename (filename ^ ".new") filename;
621 print_msg (sprintf (f_"Wrote settings to %s") filename);
626 print_msg (s_"Error" ^ ": " ^ err);
628 | Unix.Unix_error (err, fn, str) ->
629 print_msg (s_"Error" ^ ": " ^
630 (Unix.error_message err) ^ " " ^ fn ^ " " ^ str);
634 and show_help (_, _, _, _, _, _, hostname,
635 (libvirt_major, libvirt_minor, libvirt_release)) =
638 (* Get the screen/window size. *)
639 let lines, cols = get_size () in
641 (* Banner at the top of the screen. *)
643 sprintf (f_"virt-top %s ocaml-libvirt %s libvirt %d.%d.%d by Red Hat")
645 Libvirt_version.version
646 libvirt_major libvirt_minor libvirt_release in
647 let banner = pad cols banner in
655 (f_"Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s")
656 (float !delay /. 1000.)
657 (if !batch_mode then s_"On" else s_"Off")
658 (if !secure_mode then s_"On" else s_"Off")
659 (printable_sort_order !sort_order));
662 (f_"Connect: %s; Hostname: %s")
663 (match !uri with None -> s_"default" | Some s -> s)
666 (* Misc keys on left. *)
667 let banner = pad 38 (s_"MAIN KEYS") in
669 mvaddstr header_lineno 1 banner;
673 let lineno = ref domains_lineno in
674 fun () -> let i = !lineno in incr lineno; i
676 let key keys description =
677 let lineno = get_lineno () in
678 move lineno 1; attron A.bold; addstr keys; attroff A.bold;
679 move lineno 10; addstr description
681 key "space ^L" (s_"Update display");
683 key "d s" (s_"Set update interval");
685 key "B" (s_"toggle block info req/bytes");
688 ignore (get_lineno ());
689 let banner = pad 38 (s_"SORTING") in
691 mvaddstr (get_lineno ()) 1 banner;
694 key "P" (s_"Sort by %CPU");
695 key "M" (s_"Sort by %MEM");
696 key "T" (s_"Sort by TIME");
697 key "N" (s_"Sort by ID");
698 key "F" (s_"Select sort field");
700 (* Display modes on right. *)
701 let banner = pad 39 (s_"DISPLAY MODES") in
703 mvaddstr header_lineno 40 banner;
707 let lineno = ref domains_lineno in
708 fun () -> let i = !lineno in incr lineno; i
710 let key keys description =
711 let lineno = get_lineno () in
712 move lineno 40; attron A.bold; addstr keys; attroff A.bold;
713 move lineno 49; addstr description
715 key "0" (s_"Domains display");
716 key "1" (s_"Toggle physical CPUs");
717 key "2" (s_"Toggle network interfaces");
718 key "3" (s_"Toggle block devices");
720 (* Update screen and wait for key press. *)
722 (s_"More help in virt-top(1) man page. Press any key to return.");
726 and unknown_command k =
727 print_msg (s_"Unknown command - try 'h' for help");