virt-top/virt_top.ml

   1 (* 'top'-like tool for libvirt domains.
   2  * $Id: virt_top.ml,v 1.5 2007/08/30 13:52:40 rjones Exp $
   3  *)
   4
   5 open Printf
   6 open ExtList
   7 open Curses
   8
   9 module C = Libvirt.Connect
  10 module D = Libvirt.Domain
  11 module N = Libvirt.Network
  12
  13 (* Hook for XML support (see virt_top_xml.ml). *)
  14 let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref =
  15   ref (
  16     fun _ _ -> [], []
  17   )
  18
  19 (* Hooks for CSV support (see virt_top_csv.ml). *)
  20 let csv_start : (string -> unit) ref =
  21   ref (
  22     fun _ -> failwith "virt-top was compiled without support for CSV"
  23   )
  24 let csv_write : (string list -> unit) ref =
  25   ref (
  26     fun _ -> ()
  27   )
  28
  29 (* Int64 operators for convenience. *)
  30 let (+^) = Int64.add
  31 let (-^) = Int64.sub
  32 let ( *^ ) = Int64.mul
  33 let (/^) = Int64.div
  34
  35 type sort_order =
  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
  41 ]
  42 let printable_sort_order = function
  43   | Processor -> "%CPU"
  44   | Memory -> "%MEM"
  45   | Time -> "TIME (CPU time)"
  46   | DomainID -> "Domain ID"
  47   | DomainName -> "Domain name"
  48   | NetRX -> "Net RX bytes"
  49   | NetTX -> "Net TX bytes"
  50   | BlockRdRq -> "Block read reqs"
  51   | BlockWrRq -> "Block write reqs"
  52
  53 (* Current major display mode: TaskDisplay is the normal display. *)
  54 type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay
  55
  56 (* Settings. *)
  57 let quit = ref false
  58 let delay = ref 3000 (* milliseconds *)
  59 let historical_cpu_delay = ref 20 (* secs *)
  60 let iterations = ref (-1)
  61 let batch_mode = ref false
  62 let secure_mode = ref false
  63 let sort_order = ref Processor
  64 let display_mode = ref TaskDisplay
  65 let uri = ref None
  66 let debug_file = ref ""
  67 let csv_enabled = ref false
  68
  69 (* Function to read command line arguments and go into curses mode. *)
  70 let start_up () =
  71   (* Read command line arguments. *)
  72   let rec set_delay newdelay =
  73     if newdelay <= 0. then
  74       failwith "-d: cannot set a negative delay";
  75     delay := int_of_float (newdelay *. 1000.)
  76   and set_uri = function "" -> uri := None | u -> uri := Some u
  77   and set_sort = function
  78     | "cpu" | "processor" -> sort_order := Processor
  79     | "mem" | "memory" -> sort_order := Memory
  80     | "time" -> sort_order := Time
  81     | "id" -> sort_order := DomainID
  82     | "name" -> sort_order := DomainName
  83     | "netrx" -> sort_order := NetRX | "nettx" -> sort_order := NetTX
  84     | "blockrdrq" -> sort_order := BlockRdRq
  85     | "blockwrrq" -> sort_order := BlockWrRq
  86     | str -> failwith (str ^ ": sort order should be: cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq")
  87   and set_pcpu_mode () = display_mode := PCPUDisplay
  88   and set_net_mode () = display_mode := NetDisplay
  89   and set_block_mode () = display_mode := BlockDisplay
  90   and set_csv filename =
  91     (!csv_start) filename;
  92     csv_enabled := true
  93   in
  94   let argspec = Arg.align [
  95     "-1", Arg.Unit set_pcpu_mode, " Start by displaying pCPUs (default: tasks)";
  96     "-2", Arg.Unit set_net_mode, " Start by displaying network interfaces";
  97     "-3", Arg.Unit set_block_mode, " Start by displaying block devices";
  98     "-b", Arg.Set batch_mode, " Batch mode";
  99     "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)";
 100     "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)";
 101     "--csv", Arg.String set_csv, "file Log statistics to CSV file";
 102     "-d", Arg.Float set_delay, "delay Delay time interval (seconds)";
 103     "--debug", Arg.Set_string debug_file, "file Send debug messages to file";
 104     "--hist-cpu", Arg.Set_int historical_cpu_delay, "secs Historical CPU delay";
 105     "-n", Arg.Set_int iterations, "iterations Number of iterations to run";
 106     "-o", Arg.String set_sort, "sort Set sort order (cpu|mem|time|id|name)";
 107     "-s", Arg.Set secure_mode, " Secure (\"kiosk\") mode";
 108   ] in
 109   let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
 110   let usage_msg = "virt-top : a 'top'-like utility for virtualization
 111
 112 SUMMARY
 113   virt-top [-options]
 114
 115 OPTIONS" in
 116   Arg.parse argspec anon_fun usage_msg;
 117
 118   (* Connect to the hypervisor before going into curses mode, since
 119    * this is the most likely thing to fail.
 120    *)
 121   let conn =
 122     let name = !uri in
 123     try C.connect_readonly ?name ()
 124     with
 125       Libvirt.Virterror err ->
 126         prerr_endline (Libvirt.Virterror.to_string err);
 127         (* If non-root and no explicit connection URI, print a warning. *)
 128         if Unix.geteuid () <> 0 && name = None then (
 129           print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
 130         );
 131         exit 1 in
 132
 133   (* Get the node_info.  This never changes, right?  So we get it just once. *)
 134   let node_info = C.get_node_info conn in
 135
 136   (* Hostname and libvirt library version also don't change. *)
 137   let hostname =
 138     try C.get_hostname conn
 139     with
 140     | Invalid_argument "virConnectGetHostname not supported" -> "unknown" in
 141
 142   let libvirt_version =
 143     let v, _ = Libvirt.get_version () in
 144     v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
 145
 146   (* Open debug file if specified.
 147    * NB: Do this just before jumping into curses mode.
 148    *)
 149   (match !debug_file with
 150    | "" -> (* No debug file specified, send stderr to /dev/null. *)
 151        (try
 152           let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o644 in
 153           Unix.dup2 fd Unix.stderr;
 154           Unix.close fd
 155         with
 156           Unix.Unix_error _ -> ()
 157        )
 158    | filename -> (* Send stderr to the named file. *)
 159        let fd =
 160          Unix.openfile filename [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC]
 161            0o644 in
 162        Unix.dup2 fd Unix.stderr;
 163        Unix.close fd
 164   );
 165
 166   (* Curses voodoo (see ncurses(3)). *)
 167   let stdscr =
 168     initscr ();
 169     cbreak ();
 170     noecho ();
 171     nonl ();
 172     let stdscr = stdscr () in
 173     intrflush stdscr false;
 174     keypad stdscr true;
 175     stdscr in
 176
 177   (* This tuple of static information is called 'state' in other parts
 178    * of this program, and is passed to other functions such as redraw and
 179    * main_loop.  See virt_top_main.ml.  It's not really "state" though.
 180    *)
 181   conn, stdscr, node_info, hostname, libvirt_version
 182
 183 (* Show a percentage in 4 chars. *)
 184 let show_percent percent =
 185   if percent <= 0. then " 0.0"
 186   else if percent <= 9.9 then sprintf " %1.1f" percent
 187   else if percent <= 99.9 then sprintf "%2.1f" percent
 188   else "100 "
 189
 190 (* Show an int64 option in 4 chars. *)
 191 let rec show_int64_option = function
 192   | None -> "    "
 193   | Some n -> show_int64 n
 194 (* Show an int64 in 4 chars. *)
 195 and show_int64 = function
 196   | n when n < 0L -> "-!!!"
 197   | n when n <= 9999L ->
 198       sprintf "%4Ld" n
 199   | n when n /^ 1024L <= 999L ->
 200       sprintf "%3LdK" (n /^ 1024L)
 201   | n when n /^ 1_048_576L <= 999L ->
 202       sprintf "%3LdM" (n /^ 1_048_576L)
 203   | n when n /^ 1_073_741_824L <= 999L ->
 204       sprintf "%3LdG" (n /^ 1_073_741_824L)
 205   | _ -> ">!!!"
 206
 207 (* Format the total time (may be large!) in 9 chars. *)
 208 let show_time ns =
 209   let secs_in_ns = 1_000_000_000L in
 210   let mins_in_ns = 60_000_000_000L in
 211   let hours_in_ns = 3_600_000_000_000L in
 212
 213   let hours = ns /^ hours_in_ns in
 214   let ns = ns -^ (hours *^ hours_in_ns) in
 215   let mins = ns /^ mins_in_ns in
 216   let ns = ns -^ (mins *^ mins_in_ns) in
 217   let secs = ns /^ secs_in_ns in
 218   let ns = ns -^ (secs *^ secs_in_ns) in
 219   let pennies = ns /^ 10_000_000L in
 220
 221   if hours < 12L then
 222     sprintf "%3Ld:%02Ld.%02Ld" (hours *^ 60L +^ mins) secs pennies
 223   else if hours <= 999L then
 224     sprintf "%3Ld:%02Ld:%02Ld" hours mins secs
 225   else (
 226     let days = hours /^ 24L in
 227     let hours = hours -^ (days *^ 24L) in
 228     sprintf "%3Ldd%02Ld:%02Ld" days hours mins
 229   )
 230
 231 (* Show a domain state (the 'S' column). *)
 232 let show_state = function
 233   | D.InfoNoState -> '?'
 234   | D.InfoRunning -> 'R'
 235   | D.InfoBlocked -> 'S'
 236   | D.InfoPaused -> 'P'
 237   | D.InfoShutdown -> 'D'
 238   | D.InfoShutoff -> 'O'
 239   | D.InfoCrashed -> 'X'
 240
 241 (* Sum Domain.block_stats structures together.  Missing fields
 242  * get forced to 0.  Empty list returns all 0.
 243  *)
 244 let zero_block_stats =
 245   { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L }
 246 let add_block_stats bs1 bs2 =
 247   let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
 248   { D.rd_req = add bs1.D.rd_req   bs2.D.rd_req;
 249     rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes;
 250     wr_req   = add bs1.D.wr_req   bs2.D.wr_req;
 251     wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes;
 252     errs     = add bs1.D.errs     bs2.D.errs }
 253 let sum_block_stats =
 254   List.fold_left add_block_stats zero_block_stats
 255
 256 (* Get the difference between two block_stats structures.  Missing data
 257  * forces the difference to -1.
 258  *)
 259 let diff_block_stats curr prev =
 260   let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
 261   { D.rd_req = sub curr.D.rd_req   prev.D.rd_req;
 262     rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes;
 263     wr_req   = sub curr.D.wr_req   prev.D.wr_req;
 264     wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes;
 265     errs     = sub curr.D.errs     prev.D.errs }
 266
 267 (* Sum Domain.interface_stats structures together.  Missing fields
 268  * get forced to 0.  Empty list returns all 0.
 269  *)
 270 let zero_interface_stats =
 271   { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L;
 272     tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L }
 273 let add_interface_stats is1 is2 =
 274   let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
 275   { D.rx_bytes = add is1.D.rx_bytes   is2.D.rx_bytes;
 276     rx_packets = add is1.D.rx_packets is2.D.rx_packets;
 277     rx_errs    = add is1.D.rx_errs    is2.D.rx_errs;
 278     rx_drop    = add is1.D.rx_drop    is2.D.rx_drop;
 279     tx_bytes   = add is1.D.tx_bytes   is2.D.tx_bytes;
 280     tx_packets = add is1.D.tx_packets is2.D.tx_packets;
 281     tx_errs    = add is1.D.tx_errs    is2.D.tx_errs;
 282     tx_drop    = add is1.D.tx_drop    is2.D.tx_drop }
 283 let sum_interface_stats =
 284   List.fold_left add_interface_stats zero_interface_stats
 285
 286 (* Get the difference between two interface_stats structures.
 287  * Missing data forces the difference to -1.
 288  *)
 289 let diff_interface_stats curr prev =
 290   let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
 291   { D.rx_bytes = sub curr.D.rx_bytes   prev.D.rx_bytes;
 292     rx_packets = sub curr.D.rx_packets prev.D.rx_packets;
 293     rx_errs    = sub curr.D.rx_errs    prev.D.rx_errs;
 294     rx_drop    = sub curr.D.rx_drop    prev.D.rx_drop;
 295     tx_bytes   = sub curr.D.tx_bytes   prev.D.tx_bytes;
 296     tx_packets = sub curr.D.tx_packets prev.D.tx_packets;
 297     tx_errs    = sub curr.D.tx_errs    prev.D.tx_errs;
 298     tx_drop    = sub curr.D.tx_drop    prev.D.tx_drop }
 299
 300 (* Update the display and sleep for given number of seconds. *)
 301 let sleep n = refresh (); Unix.sleep n
 302
 303 (* The curses getstr/getnstr functions are just weird.
 304  * This helper function also enables echo temporarily.
 305  *)
 306 let get_string maxlen =
 307   echo ();
 308   let str = String.create maxlen in
 309   let ok = getstr str in (* Safe because binding calls getnstr. *)
 310   noecho ();
 311   if not ok then ""
 312   else (
 313     (* Chop at first '\0'. *)
 314     try
 315       let i = String.index str '\000' in
 316       String.sub str 0 i
 317     with
 318       Not_found -> str (* it is full maxlen bytes *)
 319   )
 320
 321 (* Pad a string to the full width with spaces.  If too long, truncate. *)
 322 let pad width str =
 323   let n = String.length str in
 324   if n = width then str
 325   else if n > width then String.sub str 0 width
 326   else (* if n < width then *) str ^ String.make (width-n) ' '
 327
 328 (* Line numbers. *)
 329 let top_lineno = 0
 330 let summary_lineno = 1 (* this takes 2 lines *)
 331 let message_lineno = 3
 332 let header_lineno = 4
 333 let domains_lineno = 5
 334
 335 (* Print in the "message area". *)
 336 let clear_msg () = move message_lineno 0; clrtoeol ()
 337 let print_msg str = clear_msg (); mvaddstr message_lineno 0 str; ()
 338
 339 (* Write CSV header row. *)
 340 let write_csv_header () =
 341   (!csv_write) [ "Hostname"; "Time"; "Arch"; "Physical CPUs";
 342                  "Count"; "Running"; "Blocked"; "Paused"; "Shutdown";
 343                  "Shutoff"; "Crashed"; "Active"; "Inactive";
 344                  "%CPU"; "Total memory KB"; "Total guest memory KB";
 345                  "Total CPU time ns" ]
 346
 347 (* Intermediate "domain + stats" structure that we use to collect
 348  * everything we know about a domain within the redraw function.
 349  *)
 350 type rd_domain = Inactive | Active of rd_active
 351 and rd_active = {
 352   rd_domid : int;                       (* Domain ID. *)
 353   rd_dom : [`R] D.t;                    (* Domain object. *)
 354   rd_info : D.info;                     (* Domain CPU info now. *)
 355   rd_block_stats : (string * D.block_stats) list;
 356                                         (* Domain block stats now. *)
 357   rd_interface_stats : (string * D.interface_stats) list;
 358                                         (* Domain net stats now. *)
 359   rd_prev_info : D.info option;         (* Domain CPU info previously. *)
 360   rd_prev_block_stats : (string * D.block_stats) list;
 361                                         (* Domain block stats prev. *)
 362   rd_prev_interface_stats : (string * D.interface_stats) list;
 363                                         (* Domain interface stats prev. *)
 364   (* The following are since the last slice, or 0 if cannot be calculated: *)
 365   rd_cpu_time : float;                  (* CPU time used in nanoseconds. *)
 366   rd_percent_cpu : float;               (* CPU time as percent of total. *)
 367   (* The following are since the last slice, or None if cannot be calc'd: *)
 368   rd_block_rd_reqs : int64 option;      (* Number of block device read rqs. *)
 369   rd_block_wr_reqs : int64 option;      (* Number of block device write rqs. *)
 370   rd_net_rx_bytes : int64 option;       (* Number of bytes received. *)
 371   rd_net_tx_bytes : int64 option;       (* Number of bytes transmitted. *)
 372 }
 373
 374 (* Redraw the display. *)
 375 let redraw, clear_pcpu_display_data =
 376   (* We cache the list of block devices and interfaces for each domain
 377    * here, so we don't need to reparse the XML each time.
 378    *)
 379   let devices = Hashtbl.create 13 in
 380
 381   (* Function to get the list of block devices, network interfaces for
 382    * a particular domain.  Get it from the devices cache, and if not
 383    * there then parse the domain XML.
 384    *)
 385   let get_devices id dom =
 386     try Hashtbl.find devices id
 387     with Not_found ->
 388       let blkdevs, netifs = (!parse_device_xml) id dom in
 389       Hashtbl.replace devices id (blkdevs, netifs);
 390       blkdevs, netifs
 391   in
 392
 393   (* We save the state of domains across redraws here, which allows us
 394    * to deduce %CPU usage from the running total.
 395    *)
 396   let last_info = Hashtbl.create 13 in
 397   let last_time = ref (Unix.gettimeofday ()) in
 398
 399   (* Save vcpuinfo structures across redraws too (only for pCPU display). *)
 400   let last_vcpu_info = Hashtbl.create 13 in
 401
 402   (* Keep a historical list of %CPU usages. *)
 403   let historical_cpu = ref [] in
 404   let historical_cpu_last_time = ref (Unix.gettimeofday ()) in
 405
 406   let redraw (conn, stdscr, node_info, hostname, _) =
 407     clear ();
 408
 409     (* Get the screen/window size. *)
 410     let lines, cols = get_size () in
 411
 412     (* Number of physical CPUs (some may be disabled). *)
 413     let nr_pcpus = C.maxcpus_of_node_info node_info in
 414
 415     (* Get the current time. *)
 416     let time = Unix.gettimeofday () in
 417     let tm = Unix.localtime time in
 418     let printable_time =
 419       sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
 420     mvaddstr top_lineno 0 ("virt-top " ^ printable_time ^ " - ");
 421
 422     (* What's the total CPU time elapsed since we were last called? (ns) *)
 423     let total_cpu_per_pcpu = 1_000_000_000. *. (time -. !last_time) in
 424     (* Avoid division by zero. *)
 425     let total_cpu_per_pcpu =
 426       if total_cpu_per_pcpu <= 0. then 1. else total_cpu_per_pcpu in
 427     let total_cpu = float node_info.C.cpus *. total_cpu_per_pcpu in
 428
 429     (* Basic node_info. *)
 430     addstr (sprintf "%s %d/%dCPU %dMHz %LdMB "
 431               node_info.C.model node_info.C.cpus nr_pcpus node_info.C.mhz
 432               (node_info.C.memory /^ 1024L));
 433     (* Save the cursor position for when we come to draw the
 434      * historical CPU times (down in this function).
 435      *)
 436     let historical_cursor = getyx stdscr in
 437
 438     (* Get the domains.  Match up with their last_info (if any). *)
 439     let doms =
 440       (* Active domains. *)
 441       let n = C.num_of_domains conn in
 442       let ids = Array.to_list (C.list_domains conn n) in
 443       let doms =
 444         List.filter_map (
 445           fun id ->
 446             try
 447               let dom = D.lookup_by_id conn id in
 448               let name = D.get_name dom in
 449               let blkdevs, netifs = get_devices id dom in
 450
 451               (* Get current CPU, block and network stats. *)
 452               let info = D.get_info dom in
 453               let block_stats =
 454                 try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs
 455                 with
 456                 | Invalid_argument "virDomainBlockStats not supported"
 457                 | Libvirt.Virterror _ -> [] in
 458               let interface_stats =
 459                 try List.map (fun dev -> dev, D.interface_stats dom dev) netifs
 460                 with
 461                 | Invalid_argument "virDomainInterfaceStats not supported"
 462                 | Libvirt.Virterror _ -> [] in
 463
 464               let prev_info, prev_block_stats, prev_interface_stats =
 465                 try
 466                   let prev_info, prev_block_stats, prev_interface_stats =
 467                     Hashtbl.find last_info id in
 468                   Some prev_info, prev_block_stats, prev_interface_stats
 469                 with Not_found -> None, [], [] in
 470
 471               Some (name, Active {
 472                       rd_domid = id; rd_dom = dom; rd_info = info;
 473                       rd_block_stats = block_stats;
 474                       rd_interface_stats = interface_stats;
 475                       rd_prev_info = prev_info;
 476                       rd_prev_block_stats = prev_block_stats;
 477                       rd_prev_interface_stats = prev_interface_stats;
 478                       rd_cpu_time = 0.; rd_percent_cpu = 0.;
 479                       rd_block_rd_reqs = None; rd_block_wr_reqs = None;
 480                       rd_net_rx_bytes = None; rd_net_tx_bytes = None;
 481                     })
 482             with
 483               Libvirt.Virterror _ -> None (* ignore transient error *)
 484         ) ids in
 485
 486       (* Inactive domains. *)
 487       let n = C.num_of_defined_domains conn in
 488       let names = Array.to_list (C.list_defined_domains conn n) in
 489       let doms_inactive = List.map (fun name -> name, Inactive) names in
 490
 491       doms @ doms_inactive in
 492
 493     (* Calculate the CPU time (ns) and %CPU used by each domain. *)
 494     let doms =
 495       List.map (
 496         function
 497         (* We have previous CPU info from which to calculate it? *)
 498         | name, Active ({ rd_prev_info = Some prev_info } as rd) ->
 499             let cpu_time =
 500               Int64.to_float (rd.rd_info.D.cpu_time -^ prev_info.D.cpu_time) in
 501             let percent_cpu = 100. *. cpu_time /. total_cpu in
 502             let rd = { rd with
 503                          rd_cpu_time = cpu_time;
 504                          rd_percent_cpu = percent_cpu } in
 505             name, Active rd
 506         (* For all other domains we can't calculate it, so leave as 0 *)
 507         | rd -> rd
 508       ) doms in
 509
 510     (* Calculate the number of block device read/write requests across
 511      * all block devices attached to a domain.
 512      *)
 513     let doms =
 514       List.map (
 515         function
 516         (* Do we have stats from the previous slice? *)
 517         | name, Active ({ rd_prev_block_stats = ((_::_) as prev_block_stats) }
 518                           as rd) ->
 519             let block_stats = rd.rd_block_stats in (* stats now *)
 520
 521             (* Add all the devices together.  Throw away device names. *)
 522             let prev_block_stats =
 523               sum_block_stats (List.map snd prev_block_stats) in
 524             let block_stats =
 525               sum_block_stats (List.map snd block_stats) in
 526
 527             (* Calculate increase in read & write requests. *)
 528             let read_reqs =
 529               block_stats.D.rd_req -^ prev_block_stats.D.rd_req in
 530             let write_reqs =
 531               block_stats.D.wr_req -^ prev_block_stats.D.wr_req in
 532
 533             let rd = { rd with
 534                          rd_block_rd_reqs = Some read_reqs;
 535                          rd_block_wr_reqs = Some write_reqs } in
 536             name, Active rd
 537         (* For all other domains we can't calculate it, so leave as None. *)
 538         | rd -> rd
 539       ) doms in
 540
 541     (* Calculate the same as above for network interfaces across
 542      * all network interfaces attached to a domain.
 543      *)
 544     let doms =
 545       List.map (
 546         function
 547         (* Do we have stats from the previous slice? *)
 548         | name, Active ({ rd_prev_interface_stats =
 549                               ((_::_) as prev_interface_stats) }
 550                           as rd) ->
 551             let interface_stats = rd.rd_interface_stats in (* stats now *)
 552
 553             (* Add all the devices together.  Throw away device names. *)
 554             let prev_interface_stats =
 555               sum_interface_stats (List.map snd prev_interface_stats) in
 556             let interface_stats =
 557               sum_interface_stats (List.map snd interface_stats) in
 558
 559             (* Calculate increase in rx & tx bytes. *)
 560             let rx_bytes =
 561               interface_stats.D.rx_bytes -^ prev_interface_stats.D.rx_bytes in
 562             let tx_bytes =
 563               interface_stats.D.tx_bytes -^ prev_interface_stats.D.tx_bytes in
 564
 565             let rd = { rd with
 566                          rd_net_rx_bytes = Some rx_bytes;
 567                          rd_net_tx_bytes = Some tx_bytes } in
 568             name, Active rd
 569         (* For all other domains we can't calculate it, so leave as None. *)
 570         | rd -> rd
 571       ) doms in
 572
 573     (match !display_mode with
 574      | TaskDisplay -> (*---------- Showing domains ----------*)
 575          (* Sort domains on current sort_order. *)
 576          let doms =
 577            let cmp =
 578              match !sort_order with
 579              | DomainName ->
 580                  (fun _ -> 0) (* fallthrough to default name compare *)
 581              | Processor ->
 582                  (function
 583                   | Active rd1, Active rd2 ->
 584                       compare rd2.rd_percent_cpu rd1.rd_percent_cpu
 585                   | Active _, Inactive -> -1
 586                   | Inactive, Active _ -> 1
 587                   | Inactive, Inactive -> 0)
 588              | Memory ->
 589                  (function
 590                   | Active { rd_info = info1 }, Active { rd_info = info2 } ->
 591                       compare info2.D.memory info1.D.memory
 592                   | Active _, Inactive -> -1
 593                   | Inactive, Active _ -> 1
 594                   | Inactive, Inactive -> 0)
 595              | Time ->
 596                  (function
 597                   | Active { rd_info = info1 }, Active { rd_info = info2 } ->
 598                       compare info2.D.cpu_time info1.D.cpu_time
 599                   | Active _, Inactive -> -1
 600                   | Inactive, Active _ -> 1
 601                   | Inactive, Inactive -> 0)
 602              | DomainID ->
 603                  (function
 604                   | Active { rd_domid = id1 }, Active { rd_domid = id2 } ->
 605                       compare id1 id2
 606                   | Active _, Inactive -> -1
 607                   | Inactive, Active _ -> 1
 608                   | Inactive, Inactive -> 0)
 609              | NetRX ->
 610                  (function
 611                   | Active { rd_net_rx_bytes = r1 }, Active { rd_net_rx_bytes = r2 } ->
 612                       compare r2 r1
 613                   | Active _, Inactive -> -1
 614                   | Inactive, Active _ -> 1
 615                   | Inactive, Inactive -> 0)
 616              | NetTX ->
 617                  (function
 618                   | Active { rd_net_tx_bytes = r1 }, Active { rd_net_tx_bytes = r2 } ->
 619                       compare r2 r1
 620                   | Active _, Inactive -> -1
 621                   | Inactive, Active _ -> 1
 622                   | Inactive, Inactive -> 0)
 623              | BlockRdRq ->
 624                  (function
 625                   | Active { rd_block_rd_reqs = r1 }, Active { rd_block_rd_reqs = r2 } ->
 626                       compare r2 r1
 627                   | Active _, Inactive -> -1
 628                   | Inactive, Active _ -> 1
 629                   | Inactive, Inactive -> 0)
 630              | BlockWrRq ->
 631                  (function
 632                   | Active { rd_block_wr_reqs = r1 }, Active { rd_block_wr_reqs = r2 } ->
 633                       compare r2 r1
 634                   | Active _, Inactive -> -1
 635                   | Inactive, Active _ -> 1
 636                   | Inactive, Inactive -> 0)
 637            in
 638            let cmp (name1, dom1) (name2, dom2) =
 639              let r = cmp (dom1, dom2) in
 640              if r <> 0 then r
 641              else compare name1 name2
 642            in
 643            List.sort ~cmp doms in
 644
 645          (* Print domains. *)
 646          attron A.reverse;
 647          mvaddstr header_lineno 0
 648            (pad cols "   ID S RDRQ WRRQ RXBY TXBY %CPU %MEM    TIME   NAME");
 649          attroff A.reverse;
 650
 651          let rec loop lineno = function
 652            | [] -> ()
 653            | (name, Active rd) :: doms ->
 654                if lineno < lines then (
 655                  let state = show_state rd.rd_info.D.state in
 656                  let rd_req = show_int64_option rd.rd_block_rd_reqs in
 657                  let wr_req = show_int64_option rd.rd_block_wr_reqs in
 658                  let rx_bytes = show_int64_option rd.rd_net_rx_bytes in
 659                  let tx_bytes = show_int64_option rd.rd_net_tx_bytes in
 660                  let percent_cpu = show_percent rd.rd_percent_cpu in
 661                  let percent_mem =
 662                    100L *^ rd.rd_info.D.memory /^ node_info.C.memory in
 663                  let percent_mem = Int64.to_float percent_mem in
 664                  let percent_mem = show_percent percent_mem in
 665                  let time = show_time rd.rd_info.D.cpu_time in
 666
 667                  let line = sprintf "%5d %c %s %s %s %s %s %s %s %s"
 668                    rd.rd_domid state rd_req wr_req rx_bytes tx_bytes
 669                    percent_cpu percent_mem time name in
 670                  let line = pad cols line in
 671                  mvaddstr lineno 0 line;
 672                  loop (lineno+1) doms
 673                )
 674            | (name, Inactive) :: doms -> (* inactive domain *)
 675                if lineno < lines then (
 676                  let line =
 677                    sprintf
 678                      "    -                                           (%s)"
 679                      name in
 680                  let line = pad cols line in
 681                  mvaddstr lineno 0 line;
 682                  loop (lineno+1) doms
 683                )
 684          in
 685          loop domains_lineno doms
 686
 687      | PCPUDisplay -> (*---------- Showing physical CPUs ----------*)
 688          (* Get the VCPU info and VCPU->PCPU mappings for active domains.
 689           * Also cull some data we don't care about.
 690           *)
 691          let doms = List.filter_map (
 692            function
 693            | (name, Active rd) ->
 694                (try
 695                   let domid = rd.rd_domid in
 696                   let maplen = C.cpumaplen nr_pcpus in
 697                   let maxinfo = rd.rd_info.D.nr_virt_cpu in
 698                   let nr_vcpus, vcpu_infos, cpumaps =
 699                     D.get_vcpus rd.rd_dom maxinfo maplen in
 700
 701                   (* Got previous vcpu_infos for this domain? *)
 702                   let prev_vcpu_infos =
 703                     try Some (Hashtbl.find last_vcpu_info domid)
 704                     with Not_found -> None in
 705                   (* Update last_vcpu_info. *)
 706                   Hashtbl.replace last_vcpu_info domid vcpu_infos;
 707
 708                   (match prev_vcpu_infos with
 709                    | Some prev_vcpu_infos
 710                        when Array.length prev_vcpu_infos = Array.length vcpu_infos ->
 711                        Some (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
 712                              cpumaps, maplen)
 713                    | _ -> None (* ignore missing / unequal length prev_vcpu_infos *)
 714                   );
 715                 with
 716                   Libvirt.Virterror _ -> None(* ignore transient libvirt errs *)
 717                )
 718            | (_, Inactive) -> None (* ignore inactive doms *)
 719          ) doms in
 720          let nr_doms = List.length doms in
 721
 722          (* Rearrange the data into a matrix.  Major axis (down) is
 723           * pCPUs.  Minor axis (right) is domains.  At each node we store:
 724           *  cpu_time (on this pCPU only, nanosecs),
 725           *  average? (if set, then cpu_time is an average because the
 726           *     vCPU is pinned to more than one pCPU)
 727           *  running? (if set, we were instantaneously running on this pCPU)
 728           *)
 729          let empty_node = (0L, false, false) in
 730          let pcpus = Array.make_matrix nr_pcpus nr_doms empty_node in
 731
 732          List.iteri (
 733            fun di (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
 734                    cpumaps, maplen) ->
 735              (* Which pCPUs can this dom run on? *)
 736              for v = 0 to nr_vcpus-1 do
 737                let pcpu = vcpu_infos.(v).D.cpu in (* instantaneous pCPU *)
 738                let nr_poss_pcpus = ref 0 in (* how many pcpus can it run on? *)
 739                for p = 0 to nr_pcpus-1 do
 740                  (* vcpu v can reside on pcpu p *)
 741                  if C.cpu_usable cpumaps maplen v p then
 742                    incr nr_poss_pcpus
 743                done;
 744                let nr_poss_pcpus = Int64.of_int !nr_poss_pcpus in
 745                for p = 0 to nr_pcpus-1 do
 746                  (* vcpu v can reside on pcpu p *)
 747                  if C.cpu_usable cpumaps maplen v p then
 748                    let vcpu_time_on_pcpu =
 749                      vcpu_infos.(v).D.vcpu_time
 750                      -^ prev_vcpu_infos.(v).D.vcpu_time in
 751                    let vcpu_time_on_pcpu =
 752                      vcpu_time_on_pcpu /^ nr_poss_pcpus in
 753                    pcpus.(p).(di) <-
 754                      (vcpu_time_on_pcpu, nr_poss_pcpus > 1L, p = pcpu)
 755                done
 756              done
 757          ) doms;
 758
 759          (* Sum the CPU time used by each pCPU, for the %CPU column. *)
 760          let pcpus_cpu_time = Array.map (
 761            fun row ->
 762              let cpu_time = ref 0L in
 763              for di = 0 to Array.length row-1 do
 764                let t, _, _ = row.(di) in
 765                cpu_time := !cpu_time +^ t
 766              done;
 767              Int64.to_float !cpu_time
 768          ) pcpus in
 769
 770          (* Display the pCPUs. *)
 771          let dom_names =
 772            String.concat "" (
 773              List.map (
 774                fun (_, name, _, _, _, _, _) ->
 775                  let len = String.length name in
 776                  let width = max (len+1) 7 in
 777                  pad width name
 778              ) doms
 779            ) in
 780          attron A.reverse;
 781          mvaddstr header_lineno 0 (pad cols ("PHYCPU %CPU " ^ dom_names));
 782          attroff A.reverse;
 783
 784          Array.iteri (
 785            fun p row ->
 786              mvaddstr (p+domains_lineno) 0 (sprintf "%4d   " p);
 787              let cpu_time = pcpus_cpu_time.(p) in (* ns used on this CPU *)
 788              let percent_cpu = 100. *. cpu_time /. total_cpu_per_pcpu in
 789              addstr (show_percent percent_cpu);
 790              addch 32;
 791
 792              List.iteri (
 793                fun di (domid, name, _, _, _, _, _) ->
 794                  let t, is_average, is_running = pcpus.(p).(di) in
 795                  let len = String.length name in
 796                  let width = max (len+1) 7 in
 797                  let str =
 798                    if t <= 0L then ""
 799                    else (
 800                      let t = Int64.to_float t in
 801                      let percent = 100. *. t /. total_cpu_per_pcpu in
 802                      sprintf "%s%c%c " (show_percent percent)
 803                        (if is_average then '=' else ' ')
 804                        (if is_running then '#' else ' ')
 805                    ) in
 806                  addstr (pad width str);
 807                  ()
 808              ) doms
 809          ) pcpus;
 810
 811      | NetDisplay -> (*---------- Showing network interfaces ----------*)
 812          (* Only care about active domains. *)
 813          let doms = List.filter_map (
 814            function
 815            | (name, Active rd) -> Some (name, rd)
 816            | (_, Inactive) -> None
 817          ) doms in
 818
 819          (* For each domain we have a list of network interfaces seen
 820           * this slice, and seen in the previous slice, which we now
 821           * match up to get a list of (domain, interface) for which
 822           * we have current & previous knowledge.  (And ignore the rest).
 823           *)
 824          let devs =
 825            List.map (
 826              fun (name, rd) ->
 827                List.filter_map (
 828                  fun (dev, stats) ->
 829                    try
 830                      (* Have prev slice stats for this device? *)
 831                      let prev_stats =
 832                        List.assoc dev rd.rd_prev_interface_stats in
 833                      Some (dev, name, rd, stats, prev_stats)
 834                    with Not_found -> None
 835                ) rd.rd_interface_stats
 836            ) doms in
 837
 838          (* Finally we have a list of:
 839           * device name, domain name, rd_* stuff, curr stats, prev stats.
 840           *)
 841          let devs : (string * string * rd_active *
 842                        D.interface_stats * D.interface_stats) list =
 843            List.flatten devs in
 844
 845          (* Difference curr slice & prev slice. *)
 846          let devs = List.map (
 847            fun (dev, name, rd, curr, prev) ->
 848              dev, name, rd, diff_interface_stats curr prev
 849          ) devs in
 850
 851          (* Sort by current sort order, but map some of the standard
 852           * sort orders into ones which makes sense here.
 853           *)
 854          let devs =
 855            let cmp =
 856              match !sort_order with
 857              | DomainName ->
 858                  (fun _ -> 0) (* fallthrough to default name compare *)
 859              | DomainID ->
 860                  (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
 861                     compare id1 id2)
 862              | Processor | Memory | Time | BlockRdRq | BlockWrRq
 863                  (* fallthrough to RXBY comparison. *)
 864              | NetRX ->
 865                  (fun ({ D.rx_bytes = b1 }, _, { D.rx_bytes = b2 }, _) ->
 866                     compare b2 b1)
 867              | NetTX ->
 868                  (fun ({ D.tx_bytes = b1 }, _, { D.tx_bytes = b2 }, _) ->
 869                     compare b2 b1)
 870            in
 871            let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
 872              let r = cmp (stats1, rd1, stats2, rd2) in
 873              if r <> 0 then r
 874              else compare (dev1, name1) (dev2, name2)
 875            in
 876            List.sort ~cmp devs in
 877
 878          (* Print the header for network devices. *)
 879          attron A.reverse;
 880          mvaddstr header_lineno 0
 881            (pad cols "   ID S RXBY TXBY RXPK TXPK DOMAIN       INTERFACE");
 882          attroff A.reverse;
 883
 884          (* Print domains and devices. *)
 885          let rec loop lineno = function
 886            | [] -> ()
 887            | (dev, name, rd, stats) :: devs ->
 888                if lineno < lines then (
 889                  let state = show_state rd.rd_info.D.state in
 890                  let rx_bytes =
 891                    if stats.D.rx_bytes >= 0L
 892                    then show_int64 stats.D.rx_bytes
 893                    else "    " in
 894                  let tx_bytes =
 895                    if stats.D.tx_bytes >= 0L
 896                    then show_int64 stats.D.tx_bytes
 897                    else "    " in
 898                  let rx_packets =
 899                    if stats.D.rx_packets >= 0L
 900                    then show_int64 stats.D.rx_packets
 901                    else "    " in
 902                  let tx_packets =
 903                    if stats.D.tx_packets >= 0L
 904                    then show_int64 stats.D.tx_packets
 905                    else "    " in
 906
 907                  let line = sprintf "%5d %c %s %s %s %s %-12s %s"
 908                    rd.rd_domid state
 909                    rx_bytes tx_bytes
 910                    rx_packets tx_packets
 911                    (pad 12 name) dev in
 912                  let line = pad cols line in
 913                  mvaddstr lineno 0 line;
 914                  loop (lineno+1) devs
 915                )
 916          in
 917          loop domains_lineno devs
 918
 919      | BlockDisplay -> (*---------- Showing block devices ----------*)
 920          (* Only care about active domains. *)
 921          let doms = List.filter_map (
 922            function
 923            | (name, Active rd) -> Some (name, rd)
 924            | (_, Inactive) -> None
 925          ) doms in
 926
 927          (* For each domain we have a list of block devices seen
 928           * this slice, and seen in the previous slice, which we now
 929           * match up to get a list of (domain, device) for which
 930           * we have current & previous knowledge.  (And ignore the rest).
 931           *)
 932          let devs =
 933            List.map (
 934              fun (name, rd) ->
 935                List.filter_map (
 936                  fun (dev, stats) ->
 937                    try
 938                      (* Have prev slice stats for this device? *)
 939                      let prev_stats =
 940                        List.assoc dev rd.rd_prev_block_stats in
 941                      Some (dev, name, rd, stats, prev_stats)
 942                    with Not_found -> None
 943                ) rd.rd_block_stats
 944            ) doms in
 945
 946          (* Finally we have a list of:
 947           * device name, domain name, rd_* stuff, curr stats, prev stats.
 948           *)
 949          let devs : (string * string * rd_active *
 950                        D.block_stats * D.block_stats) list =
 951            List.flatten devs in
 952
 953          (* Difference curr slice & prev slice. *)
 954          let devs = List.map (
 955            fun (dev, name, rd, curr, prev) ->
 956              dev, name, rd, diff_block_stats curr prev
 957          ) devs in
 958
 959          (* Sort by current sort order, but map some of the standard
 960           * sort orders into ones which makes sense here.
 961           *)
 962          let devs =
 963            let cmp =
 964              match !sort_order with
 965              | DomainName ->
 966                  (fun _ -> 0) (* fallthrough to default name compare *)
 967              | DomainID ->
 968                  (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
 969                     compare id1 id2)
 970              | Processor | Memory | Time | NetRX | NetTX
 971                  (* fallthrough to RDRQ comparison. *)
 972              | BlockRdRq ->
 973                  (fun ({ D.rd_req = b1 }, _, { D.rd_req = b2 }, _) ->
 974                     compare b2 b1)
 975              | BlockWrRq ->
 976                  (fun ({ D.wr_req = b1 }, _, { D.wr_req = b2 }, _) ->
 977                     compare b2 b1)
 978            in
 979            let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
 980              let r = cmp (stats1, rd1, stats2, rd2) in
 981              if r <> 0 then r
 982              else compare (dev1, name1) (dev2, name2)
 983            in
 984            List.sort ~cmp devs in
 985
 986          (* Print the header for block devices. *)
 987          attron A.reverse;
 988          mvaddstr header_lineno 0
 989            (pad cols "   ID S RDBY WRBY RDRQ WRRQ DOMAIN       DEVICE");
 990          attroff A.reverse;
 991
 992          (* Print domains and devices. *)
 993          let rec loop lineno = function
 994            | [] -> ()
 995            | (dev, name, rd, stats) :: devs ->
 996                if lineno < lines then (
 997                  let state = show_state rd.rd_info.D.state in
 998                  let rd_bytes =
 999                    if stats.D.rd_bytes >= 0L
1000                    then show_int64 stats.D.rd_bytes
1001                    else "    " in
1002                  let wr_bytes =
1003                    if stats.D.wr_bytes >= 0L
1004                    then show_int64 stats.D.wr_bytes
1005                    else "    " in
1006                  let rd_req =
1007                    if stats.D.rd_req >= 0L
1008                    then show_int64 stats.D.rd_req
1009                    else "    " in
1010                  let wr_req =
1011                    if stats.D.wr_req >= 0L
1012                    then show_int64 stats.D.wr_req
1013                    else "    " in
1014
1015                  let line = sprintf "%5d %c %s %s %s %s %-12s %s"
1016                    rd.rd_domid state
1017                    rd_bytes wr_bytes
1018                    rd_req wr_req
1019                    (pad 12 name) dev in
1020                  let line = pad cols line in
1021                  mvaddstr lineno 0 line;
1022                  loop (lineno+1) devs
1023                )
1024          in
1025          loop domains_lineno devs
1026     );
1027
1028     (* Calculate and print totals. *)
1029     let () =
1030       let totals = List.fold_left (
1031         fun (count, running, blocked, paused, shutdown, shutoff,
1032              crashed, active, inactive,
1033              total_cpu_time, total_memory, total_domU_memory) ->
1034           function
1035           | (name, Active rd) ->
1036               let test state orig =
1037                 if rd.rd_info.D.state = state then orig+1 else orig
1038               in
1039               let running = test D.InfoRunning running in
1040               let blocked = test D.InfoBlocked blocked in
1041               let paused = test D.InfoPaused paused in
1042               let shutdown = test D.InfoShutdown shutdown in
1043               let shutoff = test D.InfoShutoff shutoff in
1044               let crashed = test D.InfoCrashed crashed in
1045
1046               let total_cpu_time = total_cpu_time +. rd.rd_cpu_time in
1047               let total_memory = total_memory +^ rd.rd_info.D.memory in
1048               let total_domU_memory = total_domU_memory +^
1049                 if rd.rd_domid > 0 then rd.rd_info.D.memory else 0L in
1050
1051               (count+1, running, blocked, paused, shutdown, shutoff,
1052                crashed, active+1, inactive,
1053                total_cpu_time, total_memory, total_domU_memory)
1054
1055           | (name, Inactive) -> (* inactive domain *)
1056               (count+1, running, blocked, paused, shutdown, shutoff,
1057                crashed, active, inactive+1,
1058                total_cpu_time, total_memory, total_domU_memory)
1059       ) (0,0,0,0,0,0,0,0,0, 0.,0L,0L) doms in
1060
1061       let (count, running, blocked, paused, shutdown, shutoff,
1062            crashed, active, inactive,
1063            total_cpu_time, total_memory, total_domU_memory) = totals in
1064
1065       mvaddstr summary_lineno 0
1066         (sprintf "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d"
1067            count active running blocked paused inactive shutdown shutoff
1068            crashed);
1069
1070       (* Total %CPU used, and memory summary. *)
1071       let percent_cpu = 100. *. total_cpu_time /. total_cpu in
1072       mvaddstr (summary_lineno+1) 0
1073         (sprintf "CPU: %2.1f%%  Mem: %Ld MB (%Ld MB by guests)"
1074            percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L));
1075
1076       (* Time to grab another historical %CPU for the list? *)
1077       if time >= !historical_cpu_last_time +. float !historical_cpu_delay
1078       then (
1079         historical_cpu := percent_cpu :: List.take 10 !historical_cpu;
1080         historical_cpu_last_time := time
1081       );
1082
1083       (* Display historical CPU time. *)
1084       let () =
1085         let x, y = historical_cursor in (* Yes, it's a bug in ocaml-curses *)
1086         let maxwidth = cols - x in
1087         let line =
1088           String.concat " "
1089             (List.map (sprintf "%2.1f%%") !historical_cpu) in
1090         let line = pad maxwidth line in
1091         mvaddstr y x line;
1092         () in
1093
1094       (* Write summary data to CSV file.  See also write_csv_header (). *)
1095       if !csv_enabled then (
1096         (!csv_write) [
1097           hostname; printable_time; node_info.C.model; string_of_int nr_pcpus;
1098           string_of_int count; string_of_int running; string_of_int blocked;
1099           string_of_int paused; string_of_int shutdown; string_of_int shutoff;
1100           string_of_int crashed; string_of_int active; string_of_int inactive;
1101           sprintf "%2.1f" percent_cpu;
1102           Int64.to_string total_memory; Int64.to_string total_domU_memory;
1103           Int64.to_string (Int64.of_float total_cpu_time)
1104         ]
1105       );
1106
1107       ()
1108     in
1109
1110     (* Update last_info, last_time. *)
1111     last_time := time;
1112     Hashtbl.clear last_info;
1113     List.iter (
1114       function
1115       | (_, Active rd) ->
1116           let info = rd.rd_info, rd.rd_block_stats, rd.rd_interface_stats in
1117           Hashtbl.add last_info rd.rd_domid info
1118       | _ -> ()
1119     ) doms;
1120
1121     move message_lineno 0 (* Park cursor in message area, as with top. *)
1122   in
1123
1124   let clear_pcpu_display_data () =
1125     (* Clear out vcpu_info used by PCPUDisplay
1126      * display_mode when we switch back to TaskDisplay mode.
1127      *)
1128     Hashtbl.clear last_vcpu_info
1129   in
1130
1131   redraw, clear_pcpu_display_data
1132
1133 (* Main loop. *)
1134 let rec main_loop state =
1135   if !csv_enabled then write_csv_header ();
1136
1137   while not !quit do
1138     redraw state;
1139     refresh ();
1140
1141     (* Clear up unused virDomainPtr objects. *)
1142     Gc.compact ();
1143
1144     if not !batch_mode then
1145       get_key_press state
1146     else (* Batch mode - just sleep, ignore keys. *)
1147       Unix.sleep (!delay / 1000);
1148
1149     (* Max iterations? *)
1150     if !iterations >= 0 then (
1151       decr iterations;
1152       if !iterations = 0 then quit := true
1153     );
1154   done
1155
1156 and get_key_press state =
1157   (* Read the next key, waiting up to !delay milliseconds. *)
1158   timeout !delay;
1159   let k = getch () in
1160   timeout (-1); (* Reset to blocking mode. *)
1161
1162   if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
1163   then (
1164     if k = Char.code 'q' then quit := true
1165     else if k = Char.code 'h' then show_help state
1166     else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
1167     else if k = Char.code 'M' then sort_order := Memory
1168     else if k = Char.code 'P' then sort_order := Processor
1169     else if k = Char.code 'T' then sort_order := Time
1170     else if k = Char.code 'N' then sort_order := DomainID
1171     else if k = Char.code 'F' then change_sort_order ()
1172     else if k = Char.code '0' then set_tasks_display ()
1173     else if k = Char.code '1' then toggle_pcpu_display ()
1174     else if k = Char.code '2' then toggle_net_display ()
1175     else if k = Char.code '3' then toggle_block_display ()
1176     else unknown_command k
1177   )
1178
1179 and change_delay () =
1180   print_msg (sprintf "Change delay from %.1f to: " (float !delay /. 1000.));
1181   let str = get_string 16 in
1182   (* Try to parse the number. *)
1183   let error =
1184     try
1185       let newdelay = float_of_string str in
1186       if newdelay <= 0. then (
1187         print_msg "Delay must be > 0"; true
1188       ) else (
1189         delay := int_of_float (newdelay *. 1000.); false
1190       )
1191     with
1192       Failure "float_of_string" ->
1193         print_msg "Not a valid number"; true in
1194   sleep (if error then 2 else 1)
1195
1196 and change_sort_order () =
1197   clear ();
1198   let lines, cols = get_size () in
1199
1200   mvaddstr top_lineno 0 "Set sort order for main display";
1201   mvaddstr summary_lineno 0 "Type key or use up and down cursor keys.";
1202
1203   attron A.reverse;
1204   mvaddstr header_lineno 0 (pad cols "KEY   Sort field");
1205   attroff A.reverse;
1206
1207   let accelerator_key = function
1208     | Memory -> "(key: M)"
1209     | Processor -> "(key: P)"
1210     | Time -> "(key: T)"
1211     | DomainID -> "(key: N)"
1212     | _ -> (* all others have to be changed from here *) ""
1213   in
1214
1215   let rec key_of_int = function
1216     | i when i < 10 -> Char.chr (i + Char.code '0')
1217     | i when i < 20 -> Char.chr (i + Char.code 'a')
1218     | _ -> assert false
1219   and int_of_key = function
1220     | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
1221     | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
1222     | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
1223     | _ -> -1
1224   in
1225
1226   (* Display possible sort fields. *)
1227   let selected_index = ref 0 in
1228   List.iteri (
1229     fun i ord ->
1230       let selected = !sort_order = ord in
1231       if selected then selected_index := i;
1232       mvaddstr (domains_lineno+i) 0
1233         (sprintf "  %c %s %s %s"
1234            (key_of_int i) (if selected then "*" else " ")
1235            (printable_sort_order ord)
1236            (accelerator_key ord))
1237   ) all_sort_fields;
1238
1239   move message_lineno 0;
1240   refresh ();
1241   let k = getch () in
1242   if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
1243     let new_order, loop =
1244       (* Redraw the display. *)
1245       if k = 12 (* ^L *) then None, true
1246       (* Make the UP and DOWN arrow keys do something useful. *)
1247       else if k = Key.up then (
1248         if !selected_index > 0 then
1249           Some (List.nth all_sort_fields (!selected_index-1)), true
1250         else
1251           None, true
1252       )
1253       else if k = Key.down then (
1254         if !selected_index < List.length all_sort_fields - 1 then
1255           Some (List.nth all_sort_fields (!selected_index+1)), true
1256         else
1257           None, true
1258       )
1259       (* Also understand the regular accelerator keys. *)
1260       else if k = Char.code 'M' then
1261         Some Memory, false
1262       else if k = Char.code 'P' then
1263         Some Processor, false
1264       else if k = Char.code 'T' then
1265         Some Time, false
1266       else if k = Char.code 'N' then
1267         Some DomainID, false
1268       else (
1269         (* It's one of the KEYs. *)
1270         let i = int_of_key k in
1271         if i >= 0 && i < List.length all_sort_fields then
1272           Some (List.nth all_sort_fields i), false
1273         else
1274           None, true
1275       ) in
1276
1277     (match new_order with
1278      | None -> ()
1279      | Some new_order ->
1280          sort_order := new_order;
1281          print_msg (sprintf "Sort order changed to: %s"
1282                       (printable_sort_order new_order));
1283          if not loop then sleep 1
1284     );
1285
1286     if loop then change_sort_order ()
1287   )
1288
1289 (* Note: We need to clear_pcpu_display_data every time
1290  * we _leave_ PCPUDisplay mode.
1291  *)
1292 and set_tasks_display () =              (* key 0 *)
1293   if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
1294   display_mode := TaskDisplay
1295
1296 and toggle_pcpu_display () =            (* key 1 *)
1297   display_mode :=
1298     match !display_mode with
1299     | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
1300     | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
1301
1302 and toggle_net_display () =             (* key 2 *)
1303   display_mode :=
1304     match !display_mode with
1305     | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
1306     | TaskDisplay | BlockDisplay -> NetDisplay
1307     | NetDisplay -> TaskDisplay
1308
1309 and toggle_block_display () =           (* key 3 *)
1310   display_mode :=
1311     match !display_mode with
1312     | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
1313     | TaskDisplay | NetDisplay -> BlockDisplay
1314     | BlockDisplay -> TaskDisplay
1315
1316 and show_help (_, _, _, hostname,
1317                (libvirt_major, libvirt_minor, libvirt_release)) =
1318   clear ();
1319
1320   (* Get the screen/window size. *)
1321   let lines, cols = get_size () in
1322
1323   (* Banner at the top of the screen. *)
1324   let banner =
1325     sprintf "virt-top %s (libvirt %d.%d.%d) by Red Hat"
1326       Libvirt_version.version libvirt_major libvirt_minor libvirt_release in
1327   let banner = pad cols banner in
1328   attron A.reverse;
1329   mvaddstr 0 0 banner;
1330   attroff A.reverse;
1331
1332   (* Status. *)
1333   mvaddstr 1 0
1334     (sprintf "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s"
1335        (float !delay /. 1000.)
1336        (if !batch_mode then "On" else "Off")
1337        (if !secure_mode then "On" else "Off")
1338        (printable_sort_order !sort_order));
1339   mvaddstr 2 0
1340     (sprintf "Connect: %s; Hostname: %s"
1341        (match !uri with None -> "default" | Some s -> s)
1342        hostname);
1343
1344   (* Misc keys on left. *)
1345   let banner = pad 38 "MAIN KEYS" in
1346   attron A.reverse;
1347   mvaddstr header_lineno 1 banner;
1348   attroff A.reverse;
1349
1350   let get_lineno =
1351     let lineno = ref domains_lineno in
1352     fun () -> let i = !lineno in incr lineno; i
1353   in
1354   let key keys description =
1355     let lineno = get_lineno () in
1356     move lineno 1; attron A.bold; addstr keys; attroff A.bold;
1357     move lineno 10; addstr description; ()
1358   in
1359   key "space ^L" "Update display";
1360   key "q"        "Quit";
1361   key "d s"      "Set update interval";
1362   key "h"        "Help";
1363
1364   (* Sort order. *)
1365   ignore (get_lineno ());
1366   let banner = pad 38 "SORTING" in
1367   attron A.reverse;
1368   mvaddstr (get_lineno ()) 1 banner;
1369   attroff A.reverse;
1370
1371   key "P" "Sort by %CPU";
1372   key "M" "Sort by %MEM";
1373   key "T" "Sort by TIME";
1374   key "N" "Sort by ID";
1375   key "F" "Select sort field";
1376
1377   (* Display modes on right. *)
1378   let banner = pad 39 "DISPLAY MODES" in
1379   attron A.reverse;
1380   mvaddstr header_lineno 40 banner;
1381   attroff A.reverse;
1382
1383   let get_lineno =
1384     let lineno = ref domains_lineno in
1385     fun () -> let i = !lineno in incr lineno; i
1386   in
1387   let key keys description =
1388     let lineno = get_lineno () in
1389     move lineno 40; attron A.bold; addstr keys; attroff A.bold;
1390     move lineno 49; addstr description; ()
1391   in
1392   key "0" "Domains display";
1393   key "1" "Toggle physical CPUs";
1394   key "2" "Toggle network interfaces";
1395   key "3" "Toggle block devices";
1396
1397   (* Update screen and wait for key press. *)
1398   mvaddstr (lines-1) 0
1399     "More help in virt-top(1) man page. Press any key to return.";
1400   refresh ();
1401   ignore (getch ())
1402
1403 and unknown_command k =
1404   print_msg "Unknown command - try 'h' for help";
1405   sleep 1