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