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 =
 443         if n > 0 then Array.to_list (C.list_domains conn n)
 444         else [] in
 445       let doms =
 446         List.filter_map (
 447           fun id ->
 448             try
 449               let dom = D.lookup_by_id conn id in
 450               let name = D.get_name dom in
 451               let blkdevs, netifs = get_devices id dom in
 452
 453               (* Get current CPU, block and network stats. *)
 454               let info = D.get_info dom in
 455               let block_stats =
 456                 try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs
 457                 with
 458                 | Invalid_argument "virDomainBlockStats not supported"
 459                 | Libvirt.Virterror _ -> [] in
 460               let interface_stats =
 461                 try List.map (fun dev -> dev, D.interface_stats dom dev) netifs
 462                 with
 463                 | Invalid_argument "virDomainInterfaceStats not supported"
 464                 | Libvirt.Virterror _ -> [] in
 465
 466               let prev_info, prev_block_stats, prev_interface_stats =
 467                 try
 468                   let prev_info, prev_block_stats, prev_interface_stats =
 469                     Hashtbl.find last_info id in
 470                   Some prev_info, prev_block_stats, prev_interface_stats
 471                 with Not_found -> None, [], [] in
 472
 473               Some (name, Active {
 474                       rd_domid = id; rd_dom = dom; rd_info = info;
 475                       rd_block_stats = block_stats;
 476                       rd_interface_stats = interface_stats;
 477                       rd_prev_info = prev_info;
 478                       rd_prev_block_stats = prev_block_stats;
 479                       rd_prev_interface_stats = prev_interface_stats;
 480                       rd_cpu_time = 0.; rd_percent_cpu = 0.;
 481                       rd_block_rd_reqs = None; rd_block_wr_reqs = None;
 482                       rd_net_rx_bytes = None; rd_net_tx_bytes = None;
 483                     })
 484             with
 485               Libvirt.Virterror _ -> None (* ignore transient error *)
 486         ) ids in
 487
 488       (* Inactive domains. *)
 489       let doms_inactive =
 490         try
 491           let n = C.num_of_defined_domains conn in
 492           let names =
 493             if n > 0 then Array.to_list (C.list_defined_domains conn n)
 494             else [] in
 495           List.map (fun name -> name, Inactive) names
 496         with
 497           (* Ignore transient errors, in particular errors from
 498            * num_of_defined_domains if it cannot contact xend.
 499            *)
 500         | Libvirt.Virterror _ -> [] in
 501
 502       doms @ doms_inactive in
 503
 504     (* Calculate the CPU time (ns) and %CPU used by each domain. *)
 505     let doms =
 506       List.map (
 507         function
 508         (* We have previous CPU info from which to calculate it? *)
 509         | name, Active ({ rd_prev_info = Some prev_info } as rd) ->
 510             let cpu_time =
 511               Int64.to_float (rd.rd_info.D.cpu_time -^ prev_info.D.cpu_time) in
 512             let percent_cpu = 100. *. cpu_time /. total_cpu in
 513             let rd = { rd with
 514                          rd_cpu_time = cpu_time;
 515                          rd_percent_cpu = percent_cpu } in
 516             name, Active rd
 517         (* For all other domains we can't calculate it, so leave as 0 *)
 518         | rd -> rd
 519       ) doms in
 520
 521     (* Calculate the number of block device read/write requests across
 522      * all block devices attached to a domain.
 523      *)
 524     let doms =
 525       List.map (
 526         function
 527         (* Do we have stats from the previous slice? *)
 528         | name, Active ({ rd_prev_block_stats = ((_::_) as prev_block_stats) }
 529                           as rd) ->
 530             let block_stats = rd.rd_block_stats in (* stats now *)
 531
 532             (* Add all the devices together.  Throw away device names. *)
 533             let prev_block_stats =
 534               sum_block_stats (List.map snd prev_block_stats) in
 535             let block_stats =
 536               sum_block_stats (List.map snd block_stats) in
 537
 538             (* Calculate increase in read & write requests. *)
 539             let read_reqs =
 540               block_stats.D.rd_req -^ prev_block_stats.D.rd_req in
 541             let write_reqs =
 542               block_stats.D.wr_req -^ prev_block_stats.D.wr_req in
 543
 544             let rd = { rd with
 545                          rd_block_rd_reqs = Some read_reqs;
 546                          rd_block_wr_reqs = Some write_reqs } in
 547             name, Active rd
 548         (* For all other domains we can't calculate it, so leave as None. *)
 549         | rd -> rd
 550       ) doms in
 551
 552     (* Calculate the same as above for network interfaces across
 553      * all network interfaces attached to a domain.
 554      *)
 555     let doms =
 556       List.map (
 557         function
 558         (* Do we have stats from the previous slice? *)
 559         | name, Active ({ rd_prev_interface_stats =
 560                               ((_::_) as prev_interface_stats) }
 561                           as rd) ->
 562             let interface_stats = rd.rd_interface_stats in (* stats now *)
 563
 564             (* Add all the devices together.  Throw away device names. *)
 565             let prev_interface_stats =
 566               sum_interface_stats (List.map snd prev_interface_stats) in
 567             let interface_stats =
 568               sum_interface_stats (List.map snd interface_stats) in
 569
 570             (* Calculate increase in rx & tx bytes. *)
 571             let rx_bytes =
 572               interface_stats.D.rx_bytes -^ prev_interface_stats.D.rx_bytes in
 573             let tx_bytes =
 574               interface_stats.D.tx_bytes -^ prev_interface_stats.D.tx_bytes in
 575
 576             let rd = { rd with
 577                          rd_net_rx_bytes = Some rx_bytes;
 578                          rd_net_tx_bytes = Some tx_bytes } in
 579             name, Active rd
 580         (* For all other domains we can't calculate it, so leave as None. *)
 581         | rd -> rd
 582       ) doms in
 583
 584     (match !display_mode with
 585      | TaskDisplay -> (*---------- Showing domains ----------*)
 586          (* Sort domains on current sort_order. *)
 587          let doms =
 588            let cmp =
 589              match !sort_order with
 590              | DomainName ->
 591                  (fun _ -> 0) (* fallthrough to default name compare *)
 592              | Processor ->
 593                  (function
 594                   | Active rd1, Active rd2 ->
 595                       compare rd2.rd_percent_cpu rd1.rd_percent_cpu
 596                   | Active _, Inactive -> -1
 597                   | Inactive, Active _ -> 1
 598                   | Inactive, Inactive -> 0)
 599              | Memory ->
 600                  (function
 601                   | Active { rd_info = info1 }, Active { rd_info = info2 } ->
 602                       compare info2.D.memory info1.D.memory
 603                   | Active _, Inactive -> -1
 604                   | Inactive, Active _ -> 1
 605                   | Inactive, Inactive -> 0)
 606              | Time ->
 607                  (function
 608                   | Active { rd_info = info1 }, Active { rd_info = info2 } ->
 609                       compare info2.D.cpu_time info1.D.cpu_time
 610                   | Active _, Inactive -> -1
 611                   | Inactive, Active _ -> 1
 612                   | Inactive, Inactive -> 0)
 613              | DomainID ->
 614                  (function
 615                   | Active { rd_domid = id1 }, Active { rd_domid = id2 } ->
 616                       compare id1 id2
 617                   | Active _, Inactive -> -1
 618                   | Inactive, Active _ -> 1
 619                   | Inactive, Inactive -> 0)
 620              | NetRX ->
 621                  (function
 622                   | Active { rd_net_rx_bytes = r1 }, Active { rd_net_rx_bytes = r2 } ->
 623                       compare r2 r1
 624                   | Active _, Inactive -> -1
 625                   | Inactive, Active _ -> 1
 626                   | Inactive, Inactive -> 0)
 627              | NetTX ->
 628                  (function
 629                   | Active { rd_net_tx_bytes = r1 }, Active { rd_net_tx_bytes = r2 } ->
 630                       compare r2 r1
 631                   | Active _, Inactive -> -1
 632                   | Inactive, Active _ -> 1
 633                   | Inactive, Inactive -> 0)
 634              | BlockRdRq ->
 635                  (function
 636                   | Active { rd_block_rd_reqs = r1 }, Active { rd_block_rd_reqs = r2 } ->
 637                       compare r2 r1
 638                   | Active _, Inactive -> -1
 639                   | Inactive, Active _ -> 1
 640                   | Inactive, Inactive -> 0)
 641              | BlockWrRq ->
 642                  (function
 643                   | Active { rd_block_wr_reqs = r1 }, Active { rd_block_wr_reqs = r2 } ->
 644                       compare r2 r1
 645                   | Active _, Inactive -> -1
 646                   | Inactive, Active _ -> 1
 647                   | Inactive, Inactive -> 0)
 648            in
 649            let cmp (name1, dom1) (name2, dom2) =
 650              let r = cmp (dom1, dom2) in
 651              if r <> 0 then r
 652              else compare name1 name2
 653            in
 654            List.sort ~cmp doms in
 655
 656          (* Print domains. *)
 657          attron A.reverse;
 658          mvaddstr header_lineno 0
 659            (pad cols "   ID S RDRQ WRRQ RXBY TXBY %CPU %MEM    TIME   NAME");
 660          attroff A.reverse;
 661
 662          let rec loop lineno = function
 663            | [] -> ()
 664            | (name, Active rd) :: doms ->
 665                if lineno < lines then (
 666                  let state = show_state rd.rd_info.D.state in
 667                  let rd_req = show_int64_option rd.rd_block_rd_reqs in
 668                  let wr_req = show_int64_option rd.rd_block_wr_reqs in
 669                  let rx_bytes = show_int64_option rd.rd_net_rx_bytes in
 670                  let tx_bytes = show_int64_option rd.rd_net_tx_bytes in
 671                  let percent_cpu = show_percent rd.rd_percent_cpu in
 672                  let percent_mem =
 673                    100L *^ rd.rd_info.D.memory /^ node_info.C.memory in
 674                  let percent_mem = Int64.to_float percent_mem in
 675                  let percent_mem = show_percent percent_mem in
 676                  let time = show_time rd.rd_info.D.cpu_time in
 677
 678                  let line = sprintf "%5d %c %s %s %s %s %s %s %s %s"
 679                    rd.rd_domid state rd_req wr_req rx_bytes tx_bytes
 680                    percent_cpu percent_mem time name in
 681                  let line = pad cols line in
 682                  mvaddstr lineno 0 line;
 683                  loop (lineno+1) doms
 684                )
 685            | (name, Inactive) :: doms -> (* inactive domain *)
 686                if lineno < lines then (
 687                  let line =
 688                    sprintf
 689                      "    -                                           (%s)"
 690                      name in
 691                  let line = pad cols line in
 692                  mvaddstr lineno 0 line;
 693                  loop (lineno+1) doms
 694                )
 695          in
 696          loop domains_lineno doms
 697
 698      | PCPUDisplay -> (*---------- Showing physical CPUs ----------*)
 699          (* Get the VCPU info and VCPU->PCPU mappings for active domains.
 700           * Also cull some data we don't care about.
 701           *)
 702          let doms = List.filter_map (
 703            function
 704            | (name, Active rd) ->
 705                (try
 706                   let domid = rd.rd_domid in
 707                   let maplen = C.cpumaplen nr_pcpus in
 708                   let maxinfo = rd.rd_info.D.nr_virt_cpu in
 709                   let nr_vcpus, vcpu_infos, cpumaps =
 710                     D.get_vcpus rd.rd_dom maxinfo maplen in
 711
 712                   (* Got previous vcpu_infos for this domain? *)
 713                   let prev_vcpu_infos =
 714                     try Some (Hashtbl.find last_vcpu_info domid)
 715                     with Not_found -> None in
 716                   (* Update last_vcpu_info. *)
 717                   Hashtbl.replace last_vcpu_info domid vcpu_infos;
 718
 719                   (match prev_vcpu_infos with
 720                    | Some prev_vcpu_infos
 721                        when Array.length prev_vcpu_infos = Array.length vcpu_infos ->
 722                        Some (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
 723                              cpumaps, maplen)
 724                    | _ -> None (* ignore missing / unequal length prev_vcpu_infos *)
 725                   );
 726                 with
 727                   Libvirt.Virterror _ -> None(* ignore transient libvirt errs *)
 728                )
 729            | (_, Inactive) -> None (* ignore inactive doms *)
 730          ) doms in
 731          let nr_doms = List.length doms in
 732
 733          (* Rearrange the data into a matrix.  Major axis (down) is
 734           * pCPUs.  Minor axis (right) is domains.  At each node we store:
 735           *  cpu_time (on this pCPU only, nanosecs),
 736           *  average? (if set, then cpu_time is an average because the
 737           *     vCPU is pinned to more than one pCPU)
 738           *  running? (if set, we were instantaneously running on this pCPU)
 739           *)
 740          let empty_node = (0L, false, false) in
 741          let pcpus = Array.make_matrix nr_pcpus nr_doms empty_node in
 742
 743          List.iteri (
 744            fun di (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
 745                    cpumaps, maplen) ->
 746              (* Which pCPUs can this dom run on? *)
 747              for v = 0 to nr_vcpus-1 do
 748                let pcpu = vcpu_infos.(v).D.cpu in (* instantaneous pCPU *)
 749                let nr_poss_pcpus = ref 0 in (* how many pcpus can it run on? *)
 750                for p = 0 to nr_pcpus-1 do
 751                  (* vcpu v can reside on pcpu p *)
 752                  if C.cpu_usable cpumaps maplen v p then
 753                    incr nr_poss_pcpus
 754                done;
 755                let nr_poss_pcpus = Int64.of_int !nr_poss_pcpus in
 756                for p = 0 to nr_pcpus-1 do
 757                  (* vcpu v can reside on pcpu p *)
 758                  if C.cpu_usable cpumaps maplen v p then
 759                    let vcpu_time_on_pcpu =
 760                      vcpu_infos.(v).D.vcpu_time
 761                      -^ prev_vcpu_infos.(v).D.vcpu_time in
 762                    let vcpu_time_on_pcpu =
 763                      vcpu_time_on_pcpu /^ nr_poss_pcpus in
 764                    pcpus.(p).(di) <-
 765                      (vcpu_time_on_pcpu, nr_poss_pcpus > 1L, p = pcpu)
 766                done
 767              done
 768          ) doms;
 769
 770          (* Sum the CPU time used by each pCPU, for the %CPU column. *)
 771          let pcpus_cpu_time = Array.map (
 772            fun row ->
 773              let cpu_time = ref 0L in
 774              for di = 0 to Array.length row-1 do
 775                let t, _, _ = row.(di) in
 776                cpu_time := !cpu_time +^ t
 777              done;
 778              Int64.to_float !cpu_time
 779          ) pcpus in
 780
 781          (* Display the pCPUs. *)
 782          let dom_names =
 783            String.concat "" (
 784              List.map (
 785                fun (_, name, _, _, _, _, _) ->
 786                  let len = String.length name in
 787                  let width = max (len+1) 7 in
 788                  pad width name
 789              ) doms
 790            ) in
 791          attron A.reverse;
 792          mvaddstr header_lineno 0 (pad cols ("PHYCPU %CPU " ^ dom_names));
 793          attroff A.reverse;
 794
 795          Array.iteri (
 796            fun p row ->
 797              mvaddstr (p+domains_lineno) 0 (sprintf "%4d   " p);
 798              let cpu_time = pcpus_cpu_time.(p) in (* ns used on this CPU *)
 799              let percent_cpu = 100. *. cpu_time /. total_cpu_per_pcpu in
 800              addstr (show_percent percent_cpu);
 801              addch 32;
 802
 803              List.iteri (
 804                fun di (domid, name, _, _, _, _, _) ->
 805                  let t, is_average, is_running = pcpus.(p).(di) in
 806                  let len = String.length name in
 807                  let width = max (len+1) 7 in
 808                  let str =
 809                    if t <= 0L then ""
 810                    else (
 811                      let t = Int64.to_float t in
 812                      let percent = 100. *. t /. total_cpu_per_pcpu in
 813                      sprintf "%s%c%c " (show_percent percent)
 814                        (if is_average then '=' else ' ')
 815                        (if is_running then '#' else ' ')
 816                    ) in
 817                  addstr (pad width str);
 818                  ()
 819              ) doms
 820          ) pcpus;
 821
 822      | NetDisplay -> (*---------- Showing network interfaces ----------*)
 823          (* Only care about active domains. *)
 824          let doms = List.filter_map (
 825            function
 826            | (name, Active rd) -> Some (name, rd)
 827            | (_, Inactive) -> None
 828          ) doms in
 829
 830          (* For each domain we have a list of network interfaces seen
 831           * this slice, and seen in the previous slice, which we now
 832           * match up to get a list of (domain, interface) for which
 833           * we have current & previous knowledge.  (And ignore the rest).
 834           *)
 835          let devs =
 836            List.map (
 837              fun (name, rd) ->
 838                List.filter_map (
 839                  fun (dev, stats) ->
 840                    try
 841                      (* Have prev slice stats for this device? *)
 842                      let prev_stats =
 843                        List.assoc dev rd.rd_prev_interface_stats in
 844                      Some (dev, name, rd, stats, prev_stats)
 845                    with Not_found -> None
 846                ) rd.rd_interface_stats
 847            ) doms in
 848
 849          (* Finally we have a list of:
 850           * device name, domain name, rd_* stuff, curr stats, prev stats.
 851           *)
 852          let devs : (string * string * rd_active *
 853                        D.interface_stats * D.interface_stats) list =
 854            List.flatten devs in
 855
 856          (* Difference curr slice & prev slice. *)
 857          let devs = List.map (
 858            fun (dev, name, rd, curr, prev) ->
 859              dev, name, rd, diff_interface_stats curr prev
 860          ) devs in
 861
 862          (* Sort by current sort order, but map some of the standard
 863           * sort orders into ones which makes sense here.
 864           *)
 865          let devs =
 866            let cmp =
 867              match !sort_order with
 868              | DomainName ->
 869                  (fun _ -> 0) (* fallthrough to default name compare *)
 870              | DomainID ->
 871                  (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
 872                     compare id1 id2)
 873              | Processor | Memory | Time | BlockRdRq | BlockWrRq
 874                  (* fallthrough to RXBY comparison. *)
 875              | NetRX ->
 876                  (fun ({ D.rx_bytes = b1 }, _, { D.rx_bytes = b2 }, _) ->
 877                     compare b2 b1)
 878              | NetTX ->
 879                  (fun ({ D.tx_bytes = b1 }, _, { D.tx_bytes = b2 }, _) ->
 880                     compare b2 b1)
 881            in
 882            let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
 883              let r = cmp (stats1, rd1, stats2, rd2) in
 884              if r <> 0 then r
 885              else compare (dev1, name1) (dev2, name2)
 886            in
 887            List.sort ~cmp devs in
 888
 889          (* Print the header for network devices. *)
 890          attron A.reverse;
 891          mvaddstr header_lineno 0
 892            (pad cols "   ID S RXBY TXBY RXPK TXPK DOMAIN       INTERFACE");
 893          attroff A.reverse;
 894
 895          (* Print domains and devices. *)
 896          let rec loop lineno = function
 897            | [] -> ()
 898            | (dev, name, rd, stats) :: devs ->
 899                if lineno < lines then (
 900                  let state = show_state rd.rd_info.D.state in
 901                  let rx_bytes =
 902                    if stats.D.rx_bytes >= 0L
 903                    then show_int64 stats.D.rx_bytes
 904                    else "    " in
 905                  let tx_bytes =
 906                    if stats.D.tx_bytes >= 0L
 907                    then show_int64 stats.D.tx_bytes
 908                    else "    " in
 909                  let rx_packets =
 910                    if stats.D.rx_packets >= 0L
 911                    then show_int64 stats.D.rx_packets
 912                    else "    " in
 913                  let tx_packets =
 914                    if stats.D.tx_packets >= 0L
 915                    then show_int64 stats.D.tx_packets
 916                    else "    " in
 917
 918                  let line = sprintf "%5d %c %s %s %s %s %-12s %s"
 919                    rd.rd_domid state
 920                    rx_bytes tx_bytes
 921                    rx_packets tx_packets
 922                    (pad 12 name) dev in
 923                  let line = pad cols line in
 924                  mvaddstr lineno 0 line;
 925                  loop (lineno+1) devs
 926                )
 927          in
 928          loop domains_lineno devs
 929
 930      | BlockDisplay -> (*---------- Showing block devices ----------*)
 931          (* Only care about active domains. *)
 932          let doms = List.filter_map (
 933            function
 934            | (name, Active rd) -> Some (name, rd)
 935            | (_, Inactive) -> None
 936          ) doms in
 937
 938          (* For each domain we have a list of block devices seen
 939           * this slice, and seen in the previous slice, which we now
 940           * match up to get a list of (domain, device) for which
 941           * we have current & previous knowledge.  (And ignore the rest).
 942           *)
 943          let devs =
 944            List.map (
 945              fun (name, rd) ->
 946                List.filter_map (
 947                  fun (dev, stats) ->
 948                    try
 949                      (* Have prev slice stats for this device? *)
 950                      let prev_stats =
 951                        List.assoc dev rd.rd_prev_block_stats in
 952                      Some (dev, name, rd, stats, prev_stats)
 953                    with Not_found -> None
 954                ) rd.rd_block_stats
 955            ) doms in
 956
 957          (* Finally we have a list of:
 958           * device name, domain name, rd_* stuff, curr stats, prev stats.
 959           *)
 960          let devs : (string * string * rd_active *
 961                        D.block_stats * D.block_stats) list =
 962            List.flatten devs in
 963
 964          (* Difference curr slice & prev slice. *)
 965          let devs = List.map (
 966            fun (dev, name, rd, curr, prev) ->
 967              dev, name, rd, diff_block_stats curr prev
 968          ) devs in
 969
 970          (* Sort by current sort order, but map some of the standard
 971           * sort orders into ones which makes sense here.
 972           *)
 973          let devs =
 974            let cmp =
 975              match !sort_order with
 976              | DomainName ->
 977                  (fun _ -> 0) (* fallthrough to default name compare *)
 978              | DomainID ->
 979                  (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
 980                     compare id1 id2)
 981              | Processor | Memory | Time | NetRX | NetTX
 982                  (* fallthrough to RDRQ comparison. *)
 983              | BlockRdRq ->
 984                  (fun ({ D.rd_req = b1 }, _, { D.rd_req = b2 }, _) ->
 985                     compare b2 b1)
 986              | BlockWrRq ->
 987                  (fun ({ D.wr_req = b1 }, _, { D.wr_req = b2 }, _) ->
 988                     compare b2 b1)
 989            in
 990            let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
 991              let r = cmp (stats1, rd1, stats2, rd2) in
 992              if r <> 0 then r
 993              else compare (dev1, name1) (dev2, name2)
 994            in
 995            List.sort ~cmp devs in
 996
 997          (* Print the header for block devices. *)
 998          attron A.reverse;
 999          mvaddstr header_lineno 0
1000            (pad cols "   ID S RDBY WRBY RDRQ WRRQ DOMAIN       DEVICE");
1001          attroff A.reverse;
1002
1003          (* Print domains and devices. *)
1004          let rec loop lineno = function
1005            | [] -> ()
1006            | (dev, name, rd, stats) :: devs ->
1007                if lineno < lines then (
1008                  let state = show_state rd.rd_info.D.state in
1009                  let rd_bytes =
1010                    if stats.D.rd_bytes >= 0L
1011                    then show_int64 stats.D.rd_bytes
1012                    else "    " in
1013                  let wr_bytes =
1014                    if stats.D.wr_bytes >= 0L
1015                    then show_int64 stats.D.wr_bytes
1016                    else "    " in
1017                  let rd_req =
1018                    if stats.D.rd_req >= 0L
1019                    then show_int64 stats.D.rd_req
1020                    else "    " in
1021                  let wr_req =
1022                    if stats.D.wr_req >= 0L
1023                    then show_int64 stats.D.wr_req
1024                    else "    " in
1025
1026                  let line = sprintf "%5d %c %s %s %s %s %-12s %s"
1027                    rd.rd_domid state
1028                    rd_bytes wr_bytes
1029                    rd_req wr_req
1030                    (pad 12 name) dev in
1031                  let line = pad cols line in
1032                  mvaddstr lineno 0 line;
1033                  loop (lineno+1) devs
1034                )
1035          in
1036          loop domains_lineno devs
1037     );
1038
1039     (* Calculate and print totals. *)
1040     let () =
1041       let totals = List.fold_left (
1042         fun (count, running, blocked, paused, shutdown, shutoff,
1043              crashed, active, inactive,
1044              total_cpu_time, total_memory, total_domU_memory) ->
1045           function
1046           | (name, Active rd) ->
1047               let test state orig =
1048                 if rd.rd_info.D.state = state then orig+1 else orig
1049               in
1050               let running = test D.InfoRunning running in
1051               let blocked = test D.InfoBlocked blocked in
1052               let paused = test D.InfoPaused paused in
1053               let shutdown = test D.InfoShutdown shutdown in
1054               let shutoff = test D.InfoShutoff shutoff in
1055               let crashed = test D.InfoCrashed crashed in
1056
1057               let total_cpu_time = total_cpu_time +. rd.rd_cpu_time in
1058               let total_memory = total_memory +^ rd.rd_info.D.memory in
1059               let total_domU_memory = total_domU_memory +^
1060                 if rd.rd_domid > 0 then rd.rd_info.D.memory else 0L in
1061
1062               (count+1, running, blocked, paused, shutdown, shutoff,
1063                crashed, active+1, inactive,
1064                total_cpu_time, total_memory, total_domU_memory)
1065
1066           | (name, Inactive) -> (* inactive domain *)
1067               (count+1, running, blocked, paused, shutdown, shutoff,
1068                crashed, active, inactive+1,
1069                total_cpu_time, total_memory, total_domU_memory)
1070       ) (0,0,0,0,0,0,0,0,0, 0.,0L,0L) doms in
1071
1072       let (count, running, blocked, paused, shutdown, shutoff,
1073            crashed, active, inactive,
1074            total_cpu_time, total_memory, total_domU_memory) = totals in
1075
1076       mvaddstr summary_lineno 0
1077         (sprintf "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d"
1078            count active running blocked paused inactive shutdown shutoff
1079            crashed);
1080
1081       (* Total %CPU used, and memory summary. *)
1082       let percent_cpu = 100. *. total_cpu_time /. total_cpu in
1083       mvaddstr (summary_lineno+1) 0
1084         (sprintf "CPU: %2.1f%%  Mem: %Ld MB (%Ld MB by guests)"
1085            percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L));
1086
1087       (* Time to grab another historical %CPU for the list? *)
1088       if time >= !historical_cpu_last_time +. float !historical_cpu_delay
1089       then (
1090         historical_cpu := percent_cpu :: List.take 10 !historical_cpu;
1091         historical_cpu_last_time := time
1092       );
1093
1094       (* Display historical CPU time. *)
1095       let () =
1096         let x, y = historical_cursor in (* Yes, it's a bug in ocaml-curses *)
1097         let maxwidth = cols - x in
1098         let line =
1099           String.concat " "
1100             (List.map (sprintf "%2.1f%%") !historical_cpu) in
1101         let line = pad maxwidth line in
1102         mvaddstr y x line;
1103         () in
1104
1105       (* Write summary data to CSV file.  See also write_csv_header (). *)
1106       if !csv_enabled then (
1107         (!csv_write) [
1108           hostname; printable_time; node_info.C.model; string_of_int nr_pcpus;
1109           string_of_int count; string_of_int running; string_of_int blocked;
1110           string_of_int paused; string_of_int shutdown; string_of_int shutoff;
1111           string_of_int crashed; string_of_int active; string_of_int inactive;
1112           sprintf "%2.1f" percent_cpu;
1113           Int64.to_string total_memory; Int64.to_string total_domU_memory;
1114           Int64.to_string (Int64.of_float total_cpu_time)
1115         ]
1116       );
1117
1118       ()
1119     in
1120
1121     (* Update last_info, last_time. *)
1122     last_time := time;
1123     Hashtbl.clear last_info;
1124     List.iter (
1125       function
1126       | (_, Active rd) ->
1127           let info = rd.rd_info, rd.rd_block_stats, rd.rd_interface_stats in
1128           Hashtbl.add last_info rd.rd_domid info
1129       | _ -> ()
1130     ) doms;
1131
1132     move message_lineno 0 (* Park cursor in message area, as with top. *)
1133   in
1134
1135   let clear_pcpu_display_data () =
1136     (* Clear out vcpu_info used by PCPUDisplay
1137      * display_mode when we switch back to TaskDisplay mode.
1138      *)
1139     Hashtbl.clear last_vcpu_info
1140   in
1141
1142   redraw, clear_pcpu_display_data
1143
1144 (* Main loop. *)
1145 let rec main_loop state =
1146   if !csv_enabled then write_csv_header ();
1147
1148   while not !quit do
1149     redraw state;
1150     refresh ();
1151
1152     (* Clear up unused virDomainPtr objects. *)
1153     Gc.compact ();
1154
1155     if not !batch_mode then
1156       get_key_press state
1157     else (* Batch mode - just sleep, ignore keys. *)
1158       Unix.sleep (!delay / 1000);
1159
1160     (* Max iterations? *)
1161     if !iterations >= 0 then (
1162       decr iterations;
1163       if !iterations = 0 then quit := true
1164     );
1165   done
1166
1167 and get_key_press state =
1168   (* Read the next key, waiting up to !delay milliseconds. *)
1169   timeout !delay;
1170   let k = getch () in
1171   timeout (-1); (* Reset to blocking mode. *)
1172
1173   if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
1174   then (
1175     if k = Char.code 'q' then quit := true
1176     else if k = Char.code 'h' then show_help state
1177     else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
1178     else if k = Char.code 'M' then sort_order := Memory
1179     else if k = Char.code 'P' then sort_order := Processor
1180     else if k = Char.code 'T' then sort_order := Time
1181     else if k = Char.code 'N' then sort_order := DomainID
1182     else if k = Char.code 'F' then change_sort_order ()
1183     else if k = Char.code '0' then set_tasks_display ()
1184     else if k = Char.code '1' then toggle_pcpu_display ()
1185     else if k = Char.code '2' then toggle_net_display ()
1186     else if k = Char.code '3' then toggle_block_display ()
1187     else unknown_command k
1188   )
1189
1190 and change_delay () =
1191   print_msg (sprintf "Change delay from %.1f to: " (float !delay /. 1000.));
1192   let str = get_string 16 in
1193   (* Try to parse the number. *)
1194   let error =
1195     try
1196       let newdelay = float_of_string str in
1197       if newdelay <= 0. then (
1198         print_msg "Delay must be > 0"; true
1199       ) else (
1200         delay := int_of_float (newdelay *. 1000.); false
1201       )
1202     with
1203       Failure "float_of_string" ->
1204         print_msg "Not a valid number"; true in
1205   sleep (if error then 2 else 1)
1206
1207 and change_sort_order () =
1208   clear ();
1209   let lines, cols = get_size () in
1210
1211   mvaddstr top_lineno 0 "Set sort order for main display";
1212   mvaddstr summary_lineno 0 "Type key or use up and down cursor keys.";
1213
1214   attron A.reverse;
1215   mvaddstr header_lineno 0 (pad cols "KEY   Sort field");
1216   attroff A.reverse;
1217
1218   let accelerator_key = function
1219     | Memory -> "(key: M)"
1220     | Processor -> "(key: P)"
1221     | Time -> "(key: T)"
1222     | DomainID -> "(key: N)"
1223     | _ -> (* all others have to be changed from here *) ""
1224   in
1225
1226   let rec key_of_int = function
1227     | i when i < 10 -> Char.chr (i + Char.code '0')
1228     | i when i < 20 -> Char.chr (i + Char.code 'a')
1229     | _ -> assert false
1230   and int_of_key = function
1231     | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
1232     | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
1233     | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
1234     | _ -> -1
1235   in
1236
1237   (* Display possible sort fields. *)
1238   let selected_index = ref 0 in
1239   List.iteri (
1240     fun i ord ->
1241       let selected = !sort_order = ord in
1242       if selected then selected_index := i;
1243       mvaddstr (domains_lineno+i) 0
1244         (sprintf "  %c %s %s %s"
1245            (key_of_int i) (if selected then "*" else " ")
1246            (printable_sort_order ord)
1247            (accelerator_key ord))
1248   ) all_sort_fields;
1249
1250   move message_lineno 0;
1251   refresh ();
1252   let k = getch () in
1253   if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
1254     let new_order, loop =
1255       (* Redraw the display. *)
1256       if k = 12 (* ^L *) then None, true
1257       (* Make the UP and DOWN arrow keys do something useful. *)
1258       else if k = Key.up then (
1259         if !selected_index > 0 then
1260           Some (List.nth all_sort_fields (!selected_index-1)), true
1261         else
1262           None, true
1263       )
1264       else if k = Key.down then (
1265         if !selected_index < List.length all_sort_fields - 1 then
1266           Some (List.nth all_sort_fields (!selected_index+1)), true
1267         else
1268           None, true
1269       )
1270       (* Also understand the regular accelerator keys. *)
1271       else if k = Char.code 'M' then
1272         Some Memory, false
1273       else if k = Char.code 'P' then
1274         Some Processor, false
1275       else if k = Char.code 'T' then
1276         Some Time, false
1277       else if k = Char.code 'N' then
1278         Some DomainID, false
1279       else (
1280         (* It's one of the KEYs. *)
1281         let i = int_of_key k in
1282         if i >= 0 && i < List.length all_sort_fields then
1283           Some (List.nth all_sort_fields i), false
1284         else
1285           None, true
1286       ) in
1287
1288     (match new_order with
1289      | None -> ()
1290      | Some new_order ->
1291          sort_order := new_order;
1292          print_msg (sprintf "Sort order changed to: %s"
1293                       (printable_sort_order new_order));
1294          if not loop then sleep 1
1295     );
1296
1297     if loop then change_sort_order ()
1298   )
1299
1300 (* Note: We need to clear_pcpu_display_data every time
1301  * we _leave_ PCPUDisplay mode.
1302  *)
1303 and set_tasks_display () =              (* key 0 *)
1304   if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
1305   display_mode := TaskDisplay
1306
1307 and toggle_pcpu_display () =            (* key 1 *)
1308   display_mode :=
1309     match !display_mode with
1310     | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
1311     | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
1312
1313 and toggle_net_display () =             (* key 2 *)
1314   display_mode :=
1315     match !display_mode with
1316     | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
1317     | TaskDisplay | BlockDisplay -> NetDisplay
1318     | NetDisplay -> TaskDisplay
1319
1320 and toggle_block_display () =           (* key 3 *)
1321   display_mode :=
1322     match !display_mode with
1323     | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
1324     | TaskDisplay | NetDisplay -> BlockDisplay
1325     | BlockDisplay -> TaskDisplay
1326
1327 and show_help (_, _, _, hostname,
1328                (libvirt_major, libvirt_minor, libvirt_release)) =
1329   clear ();
1330
1331   (* Get the screen/window size. *)
1332   let lines, cols = get_size () in
1333
1334   (* Banner at the top of the screen. *)
1335   let banner =
1336     sprintf "virt-top %s (libvirt %d.%d.%d) by Red Hat"
1337       Libvirt_version.version libvirt_major libvirt_minor libvirt_release in
1338   let banner = pad cols banner in
1339   attron A.reverse;
1340   mvaddstr 0 0 banner;
1341   attroff A.reverse;
1342
1343   (* Status. *)
1344   mvaddstr 1 0
1345     (sprintf "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s"
1346        (float !delay /. 1000.)
1347        (if !batch_mode then "On" else "Off")
1348        (if !secure_mode then "On" else "Off")
1349        (printable_sort_order !sort_order));
1350   mvaddstr 2 0
1351     (sprintf "Connect: %s; Hostname: %s"
1352        (match !uri with None -> "default" | Some s -> s)
1353        hostname);
1354
1355   (* Misc keys on left. *)
1356   let banner = pad 38 "MAIN KEYS" in
1357   attron A.reverse;
1358   mvaddstr header_lineno 1 banner;
1359   attroff A.reverse;
1360
1361   let get_lineno =
1362     let lineno = ref domains_lineno in
1363     fun () -> let i = !lineno in incr lineno; i
1364   in
1365   let key keys description =
1366     let lineno = get_lineno () in
1367     move lineno 1; attron A.bold; addstr keys; attroff A.bold;
1368     move lineno 10; addstr description; ()
1369   in
1370   key "space ^L" "Update display";
1371   key "q"        "Quit";
1372   key "d s"      "Set update interval";
1373   key "h"        "Help";
1374
1375   (* Sort order. *)
1376   ignore (get_lineno ());
1377   let banner = pad 38 "SORTING" in
1378   attron A.reverse;
1379   mvaddstr (get_lineno ()) 1 banner;
1380   attroff A.reverse;
1381
1382   key "P" "Sort by %CPU";
1383   key "M" "Sort by %MEM";
1384   key "T" "Sort by TIME";
1385   key "N" "Sort by ID";
1386   key "F" "Select sort field";
1387
1388   (* Display modes on right. *)
1389   let banner = pad 39 "DISPLAY MODES" in
1390   attron A.reverse;
1391   mvaddstr header_lineno 40 banner;
1392   attroff A.reverse;
1393
1394   let get_lineno =
1395     let lineno = ref domains_lineno in
1396     fun () -> let i = !lineno in incr lineno; i
1397   in
1398   let key keys description =
1399     let lineno = get_lineno () in
1400     move lineno 40; attron A.bold; addstr keys; attroff A.bold;
1401     move lineno 49; addstr description; ()
1402   in
1403   key "0" "Domains display";
1404   key "1" "Toggle physical CPUs";
1405   key "2" "Toggle network interfaces";
1406   key "3" "Toggle block devices";
1407
1408   (* Update screen and wait for key press. *)
1409   mvaddstr (lines-1) 0
1410     "More help in virt-top(1) man page. Press any key to return.";
1411   refresh ();
1412   ignore (getch ())
1413
1414 and unknown_command k =
1415   print_msg "Unknown command - try 'h' for help";
1416   sleep 1