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 (* Hook for calendar support (see [opt_calendar.ml]). *)
36 let parse_date_time : (string -> float) ref =
39 failwith (s_"virt-top was compiled without support for dates and times")
43 type init_file = NoInitFile | DefaultInitFile | InitFile of string
47 let delay = ref 3000 (* milliseconds *)
48 let historical_cpu_delay = ref 20 (* secs *)
49 let iterations = ref (-1)
50 let end_time = ref None
51 let batch_mode = ref false
52 let secure_mode = ref false
53 let sort_order = ref Processor
54 let display_mode = ref TaskDisplay
56 let debug_file = ref ""
57 let csv_enabled = ref false
58 let csv_cpu = ref true
59 let csv_mem = ref true
60 let csv_block = ref true
61 let csv_net = ref true
62 let init_file = ref DefaultInitFile
63 let script_mode = ref false
64 let stream_mode = ref false
65 let block_in_bytes = ref false
67 (* Function to read command line arguments and go into curses mode. *)
69 (* Read command line arguments. *)
70 let rec set_delay newdelay =
71 if newdelay <= 0. then
72 failwith (s_"-d: cannot set a negative delay");
73 delay := int_of_float (newdelay *. 1000.)
74 and set_uri = function "" -> uri := None | u -> uri := Some u
75 and set_sort order = sort_order := sort_order_of_cli order
76 and set_pcpu_mode () = display_mode := PCPUDisplay
77 and set_net_mode () = display_mode := NetDisplay
78 and set_block_mode () = display_mode := BlockDisplay
79 and set_csv filename =
80 Csv_output.csv_set_filename filename;
82 and no_init_file () = init_file := NoInitFile
83 and set_init_file filename = init_file := InitFile filename
84 and set_end_time time = end_time := Some ((!parse_date_time) time)
85 and display_version () =
86 printf "virt-top %s ocaml-libvirt %s\n"
87 Version.version Libvirt_version.version;
90 let argspec = Arg.align [
91 "-1", Arg.Unit set_pcpu_mode,
92 " " ^ s_"Start by displaying pCPUs (default: tasks)";
93 "-2", Arg.Unit set_net_mode,
94 " " ^ s_"Start by displaying network interfaces";
95 "-3", Arg.Unit set_block_mode,
96 " " ^ s_"Start by displaying block devices";
97 "-b", Arg.Set batch_mode,
99 "-c", Arg.String set_uri,
100 "uri " ^ s_"Connect to libvirt URI";
101 "--connect", Arg.String set_uri,
102 "uri " ^ s_"Connect to libvirt URI";
103 "--csv", Arg.String set_csv,
104 "file " ^ s_"Log statistics to CSV file";
105 "--no-csv-cpu", Arg.Clear csv_cpu,
106 " " ^ s_"Disable CPU stats in CSV";
107 "--no-csv-mem", Arg.Clear csv_mem,
108 " " ^ s_"Disable memory stats in CSV";
109 "--no-csv-block", Arg.Clear csv_block,
110 " " ^ s_"Disable block device stats in CSV";
111 "--no-csv-net", Arg.Clear csv_net,
112 " " ^ s_"Disable net stats in CSV";
113 "-d", Arg.Float set_delay,
114 "delay " ^ s_"Delay time interval (seconds)";
115 "--debug", Arg.Set_string debug_file,
116 "file " ^ s_"Send debug messages to file";
117 "--end-time", Arg.String set_end_time,
118 "time " ^ s_"Exit at given time";
119 "--hist-cpu", Arg.Set_int historical_cpu_delay,
120 "secs " ^ s_"Historical CPU delay";
121 "--init-file", Arg.String set_init_file,
122 "file " ^ s_"Set name of init file";
123 "--no-init-file", Arg.Unit no_init_file,
124 " " ^ s_"Do not read init file";
125 "-n", Arg.Set_int iterations,
126 "iterations " ^ s_"Number of iterations to run";
127 "-o", Arg.String set_sort,
128 "sort " ^ sprintf (f_"Set sort order (%s)")
129 "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq";
130 "-s", Arg.Set secure_mode,
131 " " ^ s_"Secure (\"kiosk\") mode";
132 "--script", Arg.Set script_mode,
133 " " ^ s_"Run from a script (no user interface)";
134 "--stream", Arg.Set stream_mode,
135 " " ^ s_"dump output to stdout (no userinterface)";
136 "--block-in-bytes", Arg.Set block_in_bytes,
137 " " ^ s_"show block device load in bytes rather than reqs";
138 "--version", Arg.Unit display_version,
139 " " ^ s_"Display version number and exit";
142 raise (Arg.Bad (sprintf (f_"%s: unknown parameter") str)) in
143 let usage_msg = s_"virt-top : a 'top'-like utility for virtualization
149 Arg.parse argspec anon_fun usage_msg;
151 (* Read the init file. *)
152 let try_to_read_init_file filename =
153 let config = read_config_file filename in
154 (* Replacement functions that raise better errors when
155 * parsing the init file.
157 let int_of_string s =
159 with Invalid_argument _ ->
160 failwithf (f_"%s: could not parse '%s' in init file: expecting an integer")
162 let float_of_string s =
163 try float_of_string s
164 with Invalid_argument _ ->
165 failwithf (f_"%s: could not parse '%s' in init file: expecting a number")
167 let bool_of_string s =
169 with Invalid_argument _ ->
170 failwithf (f_"%s: could not parse '%s' in init file: expecting %s")
171 filename s "true|false" in
174 | _, "display", mode -> display_mode := display_of_cli mode
175 | _, "delay", secs -> set_delay (float_of_string secs)
176 | _, "hist-cpu", secs -> historical_cpu_delay := int_of_string secs
177 | _, "iterations", n -> iterations := int_of_string n
178 | _, "sort", order -> set_sort order
179 | _, "connect", uri -> set_uri uri
180 | _, "debug", filename -> debug_file := filename
181 | _, "csv", filename -> set_csv filename
182 | _, "csv-cpu", b -> csv_cpu := bool_of_string b
183 | _, "csv-mem", b -> csv_mem := bool_of_string b
184 | _, "csv-block", b -> csv_block := bool_of_string b
185 | _, "csv-net", b -> csv_net := bool_of_string b
186 | _, "batch", b -> batch_mode := bool_of_string b
187 | _, "secure", b -> secure_mode := bool_of_string b
188 | _, "script", b -> script_mode := bool_of_string b
189 | _, "stream", b -> stream_mode := bool_of_string b
190 | _, "block-in-bytes", b -> block_in_bytes := bool_of_string b
191 | _, "end-time", t -> set_end_time t
192 | _, "overwrite-init-file", "false" -> no_init_file ()
194 eprintf (f_"%s:%d: configuration item ``%s'' ignored\n%!")
198 (match !init_file with
201 let home = try Sys.getenv "HOME" with Not_found -> "/" in
202 let filename = home // rcfile in
203 try_to_read_init_file filename
204 | InitFile filename ->
205 try_to_read_init_file filename
208 (* Connect to the hypervisor before going into curses mode, since
209 * this is the most likely thing to fail.
213 try C.connect_readonly ?name ()
215 Libvirt.Virterror err ->
216 prerr_endline (Libvirt.Virterror.to_string err);
217 (* If non-root and no explicit connection URI, print a warning. *)
218 if Unix.geteuid () <> 0 && name = None then (
219 print_endline (s_"NB: If you want to monitor a local hypervisor, you usually need to be root");
223 (* Get the node_info. This never changes, right? So we get it just once. *)
224 let node_info = C.get_node_info conn in
226 (* Hostname and libvirt library version also don't change. *)
228 try C.get_hostname conn
230 (* qemu:/// and other URIs didn't support virConnectGetHostname until
231 * libvirt 0.3.3. Before that they'd throw a virterror. *)
232 | Libvirt.Virterror _
233 | Libvirt.Not_supported "virConnectGetHostname" -> "unknown" in
235 let libvirt_version =
236 let v, _ = Libvirt.get_version () in
237 v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
239 (* Open debug file if specified.
240 * NB: Do this just before jumping into curses mode.
242 (match !debug_file with
243 | "" -> (* No debug file specified, send stderr to /dev/null unless
244 * we're in script mode.
246 if not !script_mode && not !stream_mode then (
247 let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o644 in
248 Unix.dup2 fd Unix.stderr;
251 | filename -> (* Send stderr to the named file. *)
253 Unix.openfile filename [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC]
255 Unix.dup2 fd Unix.stderr;
259 (* Curses voodoo (see ncurses(3)). *)
260 if not !script_mode && not !stream_mode then (
265 let stdscr = stdscr () in
266 ignore (intrflush stdscr false);
267 ignore (keypad stdscr true);
271 (* This tuple of static information is called 'setup' in other parts
272 * of this program, and is passed to other functions such as redraw and
273 * main_loop. See [main.ml].
276 !batch_mode, !script_mode, !csv_enabled, !stream_mode, (* immutable modes *)
277 node_info, hostname, libvirt_version (* info that doesn't change *)
280 (* Sleep in seconds. *)
281 let sleep = Unix.sleep
283 (* Sleep in milliseconds. *)
285 ignore (Unix.select [] [] [] (float n /. 1000.))
287 (* The curses getstr/getnstr functions are just weird.
288 * This helper function also enables echo temporarily.
290 let get_string maxlen =
292 let str = Bytes.create maxlen in
293 (* Safe because binding calls getnstr. However the unsafe cast
294 * to string is required because ocaml-curses needs to be fixed.
296 let ok = getstr (Obj.magic str) in
300 (* Chop at first '\0'. *)
302 let i = Bytes.index str '\000' in
303 Bytes.sub_string str 0 i
305 Not_found -> Bytes.to_string str (* it is full maxlen bytes *)
309 let rec main_loop ((_, batch_mode, script_mode, csv_enabled, stream_mode, _, _, _)
311 let csv_flags = !csv_cpu, !csv_mem, !csv_block, !csv_net in
314 Csv_output.write_csv_header csv_flags !block_in_bytes;
318 let state = collect setup in
320 if !display_mode = PCPUDisplay then Some (collect_pcpu state)
322 (* Redraw display. *)
323 if not script_mode && not stream_mode then
324 Redraw.redraw !display_mode !sort_order
325 setup !block_in_bytes !historical_cpu_delay
328 (* Update CSV file. *)
330 Csv_output.append_csv setup csv_flags !block_in_bytes state;
332 (* Append to stream output file. *)
334 Stream_output.append_stream setup !block_in_bytes state;
336 (* Clear up unused virDomainPtr objects. *)
339 (* Max iterations? *)
340 if !iterations >= 0 then (
342 if !iterations = 0 then quit := true
345 (* End time? We might need to adjust the precise delay down if
346 * the delay would be longer than the end time (RHBZ#637964). Note
347 * 'delay' is in milliseconds.
352 (* No --end-time option, so use the current delay. *)
355 let delay_secs = float !delay /. 1000. in
356 if end_time <= state.rd_time +. delay_secs then (
358 let delay = int_of_float (1000. *. (end_time -. state.rd_time)) in
359 if delay >= 0 then delay else 0
362 (*eprintf "adjusted delay = %d\n%!" delay;*)
364 (* Get next key. This does the sleep. *)
365 if not batch_mode && not script_mode && not stream_mode then
366 get_key_press setup delay
368 (* Batch mode, script mode, stream mode. We didn't call
369 * get_key_press, so we didn't sleep. Sleep now, unless we are
372 if not !quit || !end_time <> None then
377 and get_key_press setup delay =
378 (* Read the next key, waiting up to 'delay' milliseconds. *)
381 timeout (-1); (* Reset to blocking mode. *)
383 if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
385 if k = Char.code 'q' then quit := true
386 else if k = Char.code 'h' then show_help setup
387 else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
388 else if k = Char.code 'M' then sort_order := Memory
389 else if k = Char.code 'P' then sort_order := Processor
390 else if k = Char.code 'T' then sort_order := Time
391 else if k = Char.code 'N' then sort_order := DomainID
392 else if k = Char.code 'F' then change_sort_order ()
393 else if k = Char.code '0' then set_tasks_display ()
394 else if k = Char.code '1' then toggle_pcpu_display ()
395 else if k = Char.code '2' then toggle_net_display ()
396 else if k = Char.code '3' then toggle_block_display ()
397 else if k = Char.code 'W' then write_init_file ()
398 else if k = Char.code 'B' then toggle_block_in_bytes_mode ()
399 else unknown_command k
402 and change_delay () =
404 (sprintf (f_"Change delay from %.1f to: ") (float !delay /. 1000.));
405 let str = get_string 16 in
406 (* Try to parse the number. *)
409 let newdelay = float_of_string str in
410 if newdelay <= 0. then (
411 print_msg (s_"Delay must be > 0"); true
413 delay := int_of_float (newdelay *. 1000.); false
417 print_msg (s_"Not a valid number"); true in
419 sleep (if error then 2 else 1)
421 and change_sort_order () =
423 let lines, cols = get_size () in
425 mvaddstr top_lineno 0 (s_"Set sort order for main display");
426 mvaddstr summary_lineno 0 (s_"Type key or use up and down cursor keys.");
429 mvaddstr header_lineno 0 (pad cols "KEY Sort field");
432 let accelerator_key = function
433 | Memory -> "(key: M)"
434 | Processor -> "(key: P)"
436 | DomainID -> "(key: N)"
437 | _ -> (* all others have to be changed from here *) ""
440 let rec key_of_int = function
441 | i when i < 10 -> Char.chr (i + Char.code '0')
442 | i when i < 20 -> Char.chr (i + Char.code 'a')
444 and int_of_key = function
445 | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
446 | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
447 | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
451 (* Display possible sort fields. *)
452 let selected_index = ref 0 in
455 let selected = !sort_order = ord in
456 if selected then selected_index := i;
457 mvaddstr (domains_lineno+i) 0
458 (sprintf " %c %s %s %s"
459 (key_of_int i) (if selected then "*" else " ")
460 (printable_sort_order ord)
461 (accelerator_key ord))
464 move message_lineno 0;
467 if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
468 let new_order, loop =
469 (* Redraw the display. *)
470 if k = 12 (* ^L *) then None, true
471 (* Make the UP and DOWN arrow keys do something useful. *)
472 else if k = Key.up then (
473 if !selected_index > 0 then
474 Some (List.nth all_sort_fields (!selected_index-1)), true
478 else if k = Key.down then (
479 if !selected_index < List.length all_sort_fields - 1 then
480 Some (List.nth all_sort_fields (!selected_index+1)), true
484 (* Also understand the regular accelerator keys. *)
485 else if k = Char.code 'M' then
487 else if k = Char.code 'P' then
488 Some Processor, false
489 else if k = Char.code 'T' then
491 else if k = Char.code 'N' then
494 (* It's one of the KEYs. *)
495 let i = int_of_key k in
496 if i >= 0 && i < List.length all_sort_fields then
497 Some (List.nth all_sort_fields i), false
502 (match new_order with
505 sort_order := new_order;
506 print_msg (sprintf "Sort order changed to: %s"
507 (printable_sort_order new_order));
514 if loop then change_sort_order ()
517 (* Note: We need to clear_pcpu_display_data every time
518 * we _leave_ PCPUDisplay mode.
520 and set_tasks_display () = (* key 0 *)
521 if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
522 display_mode := TaskDisplay
524 and toggle_pcpu_display () = (* key 1 *)
526 match !display_mode with
527 | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
528 | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
530 and toggle_net_display () = (* key 2 *)
532 match !display_mode with
533 | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
534 | TaskDisplay | BlockDisplay -> NetDisplay
535 | NetDisplay -> TaskDisplay
537 and toggle_block_display () = (* key 3 *)
539 match !display_mode with
540 | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
541 | TaskDisplay | NetDisplay -> BlockDisplay
542 | BlockDisplay -> TaskDisplay
544 and toggle_block_in_bytes_mode () = (* key B *)
546 match !block_in_bytes with
550 (* Write an init file. *)
551 and write_init_file () =
552 match !init_file with
553 | NoInitFile -> () (* Do nothing if --no-init-file *)
555 let home = try Sys.getenv "HOME" with Not_found -> "/" in
556 let filename = home // rcfile in
557 _write_init_file filename
558 | InitFile filename ->
559 _write_init_file filename
561 and _write_init_file filename =
563 (* Create the new file as filename.new. *)
564 let chan = open_out (filename ^ ".new") in
566 let time = Unix.gettimeofday () in
567 let tm = Unix.localtime time in
568 let printable_date_time =
569 sprintf "%04d-%02d-%02d %02d:%02d:%02d"
570 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon+1) tm.Unix.tm_mday
571 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
574 let uid = Unix.geteuid () in
575 (Unix.getpwuid uid).Unix.pw_name
577 Not_found -> "unknown" in
580 let nl () = fp chan "\n" in
581 let () = fp chan (f_"# %s virt-top configuration file\n") rcfile in
582 let () = fp chan (f_"# generated on %s by %s\n") printable_date_time username in
584 fp chan "display %s\n" (cli_of_display !display_mode);
585 fp chan "delay %g\n" (float !delay /. 1000.);
586 fp chan "hist-cpu %d\n" !historical_cpu_delay;
587 if !iterations <> -1 then fp chan "iterations %d\n" !iterations;
588 fp chan "sort %s\n" (cli_of_sort_order !sort_order);
591 | Some uri -> fp chan "connect %s\n" uri
593 if !batch_mode = true then fp chan "batch true\n";
594 if !secure_mode = true then fp chan "secure true\n";
596 output_string chan (s_"# To send debug and error messages to a file, uncomment next line\n");
597 fp chan "#debug virt-top.out\n";
599 output_string chan (s_"# Enable CSV output to the named file\n");
600 fp chan "#csv virt-top.csv\n";
602 output_string chan (s_"# To protect this file from being overwritten, uncomment next line\n");
603 fp chan "#overwrite-init-file false\n";
607 (* If the file exists, rename it as filename.old. *)
608 (try Unix.rename filename (filename ^ ".old")
609 with Unix.Unix_error _ -> ());
611 (* Rename filename.new to filename. *)
612 Unix.rename (filename ^ ".new") filename;
614 print_msg (sprintf (f_"Wrote settings to %s") filename);
619 print_msg (s_"Error" ^ ": " ^ err);
621 | Unix.Unix_error (err, fn, str) ->
622 print_msg (s_"Error" ^ ": " ^
623 (Unix.error_message err) ^ " " ^ fn ^ " " ^ str);
627 and show_help (_, _, _, _, _, _, hostname,
628 (libvirt_major, libvirt_minor, libvirt_release)) =
631 (* Get the screen/window size. *)
632 let lines, cols = get_size () in
634 (* Banner at the top of the screen. *)
636 sprintf (f_"virt-top %s ocaml-libvirt %s libvirt %d.%d.%d by Red Hat")
638 Libvirt_version.version
639 libvirt_major libvirt_minor libvirt_release in
640 let banner = pad cols banner in
648 (f_"Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s")
649 (float !delay /. 1000.)
650 (if !batch_mode then s_"On" else s_"Off")
651 (if !secure_mode then s_"On" else s_"Off")
652 (printable_sort_order !sort_order));
655 (f_"Connect: %s; Hostname: %s")
656 (match !uri with None -> s_"default" | Some s -> s)
659 (* Misc keys on left. *)
660 let banner = pad 38 (s_"MAIN KEYS") in
662 mvaddstr header_lineno 1 banner;
666 let lineno = ref domains_lineno in
667 fun () -> let i = !lineno in incr lineno; i
669 let key keys description =
670 let lineno = get_lineno () in
671 move lineno 1; attron A.bold; addstr keys; attroff A.bold;
672 move lineno 10; addstr description
674 key "space ^L" (s_"Update display");
676 key "d s" (s_"Set update interval");
678 key "B" (s_"toggle block info req/bytes");
681 ignore (get_lineno ());
682 let banner = pad 38 (s_"SORTING") in
684 mvaddstr (get_lineno ()) 1 banner;
687 key "P" (s_"Sort by %CPU");
688 key "M" (s_"Sort by %MEM");
689 key "T" (s_"Sort by TIME");
690 key "N" (s_"Sort by ID");
691 key "F" (s_"Select sort field");
693 (* Display modes on right. *)
694 let banner = pad 39 (s_"DISPLAY MODES") in
696 mvaddstr header_lineno 40 banner;
700 let lineno = ref domains_lineno in
701 fun () -> let i = !lineno in incr lineno; i
703 let key keys description =
704 let lineno = get_lineno () in
705 move lineno 40; attron A.bold; addstr keys; attroff A.bold;
706 move lineno 49; addstr description
708 key "0" (s_"Domains display");
709 key "1" (s_"Toggle physical CPUs");
710 key "2" (s_"Toggle network interfaces");
711 key "3" (s_"Toggle block devices");
713 (* Update screen and wait for key press. *)
715 (s_"More help in virt-top(1) man page. Press any key to return.");
719 and unknown_command k =
720 print_msg (s_"Unknown command - try 'h' for help");