mlvirsh/mlvirsh.ml

   1 (* virsh-like command line tool.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18 *)
  19
  20 open ExtString
  21 open Printf
  22
  23 module C = Libvirt.Connect
  24 module D = Libvirt.Domain
  25 module N = Libvirt.Network
  26
  27 (* Program name. *)
  28 let program_name = Filename.basename Sys.executable_name
  29
  30 (* Parse arguments. *)
  31 let name = ref ""
  32 let readonly = ref false
  33
  34 let argspec = Arg.align [
  35   "-c", Arg.Set_string name, "URI Hypervisor connection URI";
  36   "-r", Arg.Set readonly, " Read-only connection";
  37 ]
  38
  39 let usage_msg = "\
  40 Synopsis:
  41   " ^ program_name ^ " [options] [command]
  42
  43 List of all commands:
  44   " ^ program_name ^ " help
  45
  46 Full description of a single command:
  47   " ^ program_name ^ " help command
  48
  49 Options:"
  50
  51 let add_extra_arg, get_extra_args =
  52   let extra_args = ref [] in
  53   let add_extra_arg s = extra_args := s :: !extra_args in
  54   let get_extra_args () = List.rev !extra_args in
  55   add_extra_arg, get_extra_args
  56
  57 let () = Arg.parse argspec add_extra_arg usage_msg
  58
  59 let name = match !name with "" -> None | name -> Some name
  60 let readonly = !readonly
  61 let extra_args = get_extra_args ()
  62
  63 (* Read a whole file into memory and return it (as a string). *)
  64 let rec input_file filename =
  65   let chan = open_in_bin filename in
  66   let data = input_all chan in
  67   close_in chan;
  68   data
  69 and input_all chan =
  70   let buf = Buffer.create 16384 in
  71   let tmpsize = 16384 in
  72   let tmp = String.create tmpsize in
  73   let n = ref 0 in
  74   while n := input chan tmp 0 tmpsize; !n > 0 do
  75     Buffer.add_substring buf tmp 0 !n;
  76   done;
  77   Buffer.contents buf
  78
  79 (* Hypervisor connection. *)
  80 type conn_t = No_connection | RO of Libvirt.ro C.t | RW of Libvirt.rw C.t
  81 let conn = ref No_connection
  82
  83 let close_connection () =
  84   match !conn with
  85   | No_connection -> ()
  86   | RO c ->
  87       C.close c;
  88       conn := No_connection
  89   | RW c ->
  90       C.close c;
  91       conn := No_connection
  92
  93 let do_command =
  94   (* Command helper functions.
  95    *
  96    * Each cmd<n> is a function that constructs a command.
  97    *    string string string  ...  <--- user types on the command line
  98    *      |      |      |
  99    *     arg1   arg2   arg3   ...  <--- conversion functions
 100    *      |      |      |
 101    *      V      V      V
 102    *         function f            <--- work function
 103    *             |
 104    *             V
 105    *        print result           <--- printing function
 106    *
 107    * (Note that cmd<n> function constructs and returns the above
 108    * function, it isn't the function itself.)
 109    *
 110    * Example: If the function takes one parameter (an int) and
 111    * returns a string to be printed, you would use:
 112    *
 113    *   cmd1 print_endline f int_of_string
 114    *)
 115   let cmd0 print fn = function          (* Command with no args. *)
 116     | [] -> print (fn ())
 117     | _ -> failwith "incorrect number of arguments for function"
 118   in
 119   let cmd1 print fn arg1 = function     (* Command with one arg. *)
 120     | [str1] -> print (fn (arg1 str1))
 121     | _ -> failwith "incorrect number of arguments for function"
 122   in
 123   let cmd2 print fn arg1 arg2 = function (* Command with 2 args. *)
 124     | [str1; str2] -> print (fn (arg1 str1) (arg2 str2))
 125     | _ -> failwith "incorrect number of arguments for function"
 126   in
 127   let cmd3 print fn arg1 arg2 arg3 = function (* Command with 3 args. *)
 128     | [str1; str2; str3] -> print (fn (arg1 str1) (arg2 str2) (arg3 str3))
 129     | _ -> failwith "incorrect number of arguments for function"
 130   in
 131   let cmd01 print fn arg1 = function    (* Command with 0 or 1 arg. *)
 132     | [] -> print (fn None)
 133     | [str1] -> print (fn (Some (arg1 str1)))
 134     | _ -> failwith "incorrect number of arguments for function"
 135   in
 136   let cmd12 print fn arg1 arg2 = function (* Command with 1 or 2 args. *)
 137     | [str1] -> print (fn (arg1 str1) None)
 138     | [str1; str2] -> print (fn (arg1 str1) (Some (arg2 str2)))
 139     | _ -> failwith "incorrect number of arguments for function"
 140   in
 141   let cmdN print fn =           (* Command with any number of args. *)
 142     fun args -> print (fn args)
 143   in
 144
 145   (* Get the connection or fail if we don't have one. *)
 146   let rec get_full_connection () =
 147     match !conn with
 148     | No_connection -> failwith "not connected to the hypervisor"
 149     | RO _ -> failwith "tried to do read-write operation on read-only hypervisor connection"
 150     | RW conn -> conn
 151   and get_readonly_connection () =
 152     match !conn with
 153     | No_connection -> failwith "not connected to the hypervisor"
 154     | RO conn -> conn
 155     | RW conn -> C.const conn
 156 (*
 157   and with_full_connection fn =
 158     fun () -> fn (get_full_connection ())
 159 *)
 160   and with_readonly_connection fn =
 161     fun () -> fn (get_readonly_connection ())
 162   and arg_full_connection fn =
 163     fun str -> fn (get_full_connection ()) str
 164   and arg_readonly_connection fn =
 165     fun str -> fn (get_readonly_connection ()) str
 166   in
 167
 168   (* Parsing of command arguments. *)
 169   let string_of_readonly = function
 170     | "readonly" | "read-only" | "ro" -> true
 171     | _ -> failwith "flag should be 'readonly'"
 172   in
 173   let string_of_string (str : string) = str in
 174   let boolean_of_string = function
 175     | "enable" | "enabled" | "on" | "1" | "true" -> true
 176     | "disable" | "disabled" | "off" | "0" | "false" -> false
 177     | _ -> failwith "setting should be 'on' or 'off'"
 178   in
 179   let domain_of_string conn str =
 180     try
 181       (try
 182          let id = int_of_string str in
 183          D.lookup_by_id conn id
 184        with
 185          Failure "int_of_string" ->
 186            if String.length str = Libvirt.uuid_string_length then
 187              D.lookup_by_uuid_string conn str
 188            else
 189              D.lookup_by_name conn str
 190       )
 191     with
 192       Libvirt.Virterror err ->
 193         failwith ("domain " ^ str ^ ": not found.  Additional info: " ^
 194                     Libvirt.Virterror.to_string err);
 195   in
 196   let network_of_string conn str =
 197     try
 198       if String.length str = Libvirt.uuid_string_length then
 199         N.lookup_by_uuid_string conn str
 200       else
 201         N.lookup_by_name conn str
 202     with
 203       Libvirt.Virterror err ->
 204         failwith ("network " ^ str ^ ": not found.  Additional info: " ^
 205                     Libvirt.Virterror.to_string err);
 206   in
 207   let rec parse_sched_params = function
 208     | [] -> []
 209     | [_] -> failwith "expected field value pairs, but got an odd number of arguments"
 210     | field :: value :: rest ->
 211         (* XXX We only support the UINT type at the moment. *)
 212         (field, D.SchedFieldUInt32 (Int32.of_string value))
 213           :: parse_sched_params rest
 214   in
 215   let cpumap_of_string str =
 216     let c = get_readonly_connection () in
 217     let info = C.get_node_info c in
 218     let cpumap =
 219       String.make (C.cpumaplen (C.maxcpus_of_node_info info)) '\000' in
 220     List.iter (C.use_cpu cpumap)
 221       (List.map int_of_string (String.nsplit str ","));
 222     cpumap
 223   in
 224
 225   (* Printing of command results. *)
 226   let no_return _ = () in
 227   let print_int i = print_endline (string_of_int i) in
 228   let print_int64 i = print_endline (Int64.to_string i) in
 229   let print_bool b = print_endline (string_of_bool b) in
 230   let print_version v =
 231     let major = v / 1000000 in
 232     let minor = (v - major * 1000000) / 1000 in
 233     let release = (v - major * 1000000 - minor * 1000) in
 234     printf "%d.%d.%d\n" major minor release
 235   in
 236   let string_of_domain_state = function
 237     | D.InfoNoState -> "unknown"
 238     | D.InfoRunning -> "running"
 239     | D.InfoBlocked -> "blocked"
 240     | D.InfoPaused -> "paused"
 241     | D.InfoShutdown -> "shutdown"
 242     | D.InfoShutoff -> "shutoff"
 243     | D.InfoCrashed -> "crashed"
 244   in
 245   let string_of_vcpu_state = function
 246     | D.VcpuOffline -> "offline"
 247     | D.VcpuRunning -> "running"
 248     | D.VcpuBlocked -> "blocked"
 249   in
 250   let print_domain_array doms =
 251     Array.iter (
 252       fun dom ->
 253         let id =
 254           try sprintf "%d" (D.get_id dom)
 255           with Libvirt.Virterror _ -> "" in
 256         let name =
 257           try sprintf "%s" (D.get_name dom)
 258           with Libvirt.Virterror _ -> "" in
 259         let state =
 260           try
 261             let { D.state = state } = D.get_info dom in
 262             string_of_domain_state state
 263           with Libvirt.Virterror _ -> "" in
 264         printf "%5s %-30s %s\n" id name state
 265     ) doms
 266   in
 267   let print_network_array nets =
 268     Array.iter (
 269       fun net ->
 270         printf "%s\n" (N.get_name net)
 271     ) nets
 272   in
 273   let print_node_info info =
 274     printf "model:   %s\n" info.C.model;
 275     printf "memory:  %Ld K\n" info.C.memory;
 276     printf "cpus:    %d\n" info.C.cpus;
 277     printf "mhz:     %d\n" info.C.mhz;
 278     printf "nodes:   %d\n" info.C.nodes;
 279     printf "sockets: %d\n" info.C.sockets;
 280     printf "cores:   %d\n" info.C.cores;
 281     printf "threads: %d\n" info.C.threads;
 282   in
 283   let print_domain_state { D.state = state } =
 284     print_endline (string_of_domain_state state)
 285   in
 286   let print_domain_info info =
 287     printf "state:       %s\n" (string_of_domain_state info.D.state);
 288     printf "max_mem:     %Ld K\n" info.D.max_mem;
 289     printf "memory:      %Ld K\n" info.D.memory;
 290     printf "nr_virt_cpu: %d\n" info.D.nr_virt_cpu;
 291     printf "cpu_time:    %Ld ns\n" info.D.cpu_time;
 292   in
 293   let print_sched_param_array params =
 294     Array.iter (
 295       fun (name, value) ->
 296         printf "%-20s" name;
 297         match value with
 298         | D.SchedFieldInt32 i -> printf " %ld\n" i
 299         | D.SchedFieldUInt32 i -> printf " %lu\n" i
 300         | D.SchedFieldInt64 i -> printf " %Ld\n" i
 301         | D.SchedFieldUInt64 i -> printf " %Lu\n" i
 302         | D.SchedFieldFloat f -> printf " %g\n" f
 303         | D.SchedFieldBool b -> printf " %b\n" b
 304     ) params
 305   in
 306   let print_vcpu_info (ncpus, vcpu_infos, cpumaps, maplen, maxcpus) =
 307     for n = 0 to ncpus-1 do
 308       printf "virtual CPU: %d\n" n;
 309       printf "  on physical CPU: %d\n" vcpu_infos.(n).D.cpu;
 310       printf "  current state:   %s\n"
 311         (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state);
 312       printf "  CPU time:        %Ld ns\n" vcpu_infos.(n).D.vcpu_time;
 313       printf "  CPU affinity:    ";
 314       for m = 0 to maxcpus-1 do
 315         print_char (if C.cpu_usable cpumaps maplen n m then 'y' else '-')
 316       done;
 317       print_endline "";
 318     done
 319   in
 320   let print_block_stats { D.rd_req = rd_req; rd_bytes = rd_bytes;
 321                           wr_req = wr_req; wr_bytes = wr_bytes;
 322                           errs = errs } =
 323     if rd_req >= 0L then   printf "read requests:  %Ld\n" rd_req;
 324     if rd_bytes >= 0L then printf "read bytes:     %Ld\n" rd_bytes;
 325     if wr_req >= 0L then   printf "write requests: %Ld\n" wr_req;
 326     if wr_bytes >= 0L then printf "write bytes:    %Ld\n" wr_bytes;
 327     if errs >= 0L then     printf "errors:         %Ld\n" errs;
 328   and print_interface_stats { D.rx_bytes = rx_bytes; rx_packets = rx_packets;
 329                               rx_errs = rx_errs; rx_drop = rx_drop;
 330                               tx_bytes = tx_bytes; tx_packets = tx_packets;
 331                               tx_errs = tx_errs; tx_drop = tx_drop } =
 332     if rx_bytes >= 0L then   printf "rx bytes:   %Ld\n" rx_bytes;
 333     if rx_packets >= 0L then printf "rx packets: %Ld\n" rx_packets;
 334     if rx_errs >= 0L then    printf "rx errs:    %Ld\n" rx_errs;
 335     if rx_drop >= 0L then    printf "rx dropped: %Ld\n" rx_drop;
 336     if tx_bytes >= 0L then   printf "tx bytes:   %Ld\n" tx_bytes;
 337     if tx_packets >= 0L then printf "tx packets: %Ld\n" tx_packets;
 338     if tx_errs >= 0L then    printf "tx errs:    %Ld\n" tx_errs;
 339     if tx_drop >= 0L then    printf "tx dropped: %Ld\n" tx_drop;
 340   in
 341
 342   (* List of commands. *)
 343   let commands = [
 344     "attach-device",
 345       cmd2 no_return D.attach_device
 346         (arg_full_connection domain_of_string) input_file,
 347       "Attach device to domain.";
 348     "autostart",
 349       cmd2 no_return D.set_autostart
 350         (arg_full_connection domain_of_string) boolean_of_string,
 351       "Set whether a domain autostarts at boot.";
 352     "capabilities",
 353       cmd0 print_endline (with_readonly_connection C.get_capabilities),
 354       "Returns capabilities of hypervisor/driver.";
 355     "close",
 356       cmd0 no_return close_connection,
 357       "Close an existing hypervisor connection.";
 358     "connect",
 359       cmd12 no_return
 360         (fun name readonly ->
 361            close_connection ();
 362            match readonly with
 363            | None | Some false -> conn := RW (C.connect ~name ())
 364            | Some true -> conn := RO (C.connect_readonly ~name ())
 365         ) string_of_string string_of_readonly,
 366       "Open a new hypervisor connection.";
 367     "create",
 368       cmd1 no_return
 369         (fun xml -> D.create_linux (get_full_connection ()) xml) input_file,
 370       "Create a domain from an XML file.";
 371     "define",
 372       cmd1 no_return
 373         (fun xml -> D.define_xml (get_full_connection ()) xml) input_file,
 374       "Define (but don't start) a domain from an XML file.";
 375     "detach-device",
 376       cmd2 no_return D.detach_device
 377         (arg_full_connection domain_of_string) input_file,
 378       "Detach device from domain.";
 379     "destroy",
 380       cmd1 no_return D.destroy (arg_full_connection domain_of_string),
 381       "Destroy a domain.";
 382     "domblkstat",
 383       cmd2 print_block_stats D.block_stats
 384         (arg_readonly_connection domain_of_string) string_of_string,
 385       "Display the block device statistics for a domain.";
 386     "domid",
 387       cmd1 print_int D.get_id (arg_readonly_connection domain_of_string),
 388       "Print the ID of a domain.";
 389     "domifstat",
 390       cmd2 print_interface_stats D.interface_stats
 391         (arg_readonly_connection domain_of_string) string_of_string,
 392       "Display the network interface statistics for a domain.";
 393     "dominfo",
 394       cmd1 print_domain_info D.get_info
 395         (arg_readonly_connection domain_of_string),
 396       "Print the domain info.";
 397     "dommaxmem",
 398       cmd1 print_int64 D.get_max_memory
 399         (arg_readonly_connection domain_of_string),
 400       "Print the max memory (in kilobytes) of a domain.";
 401     "dommaxvcpus",
 402       cmd1 print_int D.get_max_vcpus
 403         (arg_readonly_connection domain_of_string),
 404       "Print the max VCPUs of a domain.";
 405     "domname",
 406       cmd1 print_endline D.get_name
 407         (arg_readonly_connection domain_of_string),
 408       "Print the name of a domain.";
 409     "domostype",
 410       cmd1 print_endline D.get_os_type
 411         (arg_readonly_connection domain_of_string),
 412       "Print the OS type of a domain.";
 413     "domstate",
 414       cmd1 print_domain_state D.get_info
 415         (arg_readonly_connection domain_of_string),
 416       "Print the domain state.";
 417     "domuuid",
 418       cmd1 print_endline D.get_uuid_string
 419         (arg_readonly_connection domain_of_string),
 420       "Print the UUID of a domain.";
 421     "dump",
 422       cmd2 no_return D.core_dump
 423         (arg_full_connection domain_of_string) string_of_string,
 424       "Core dump a domain to a file for analysis.";
 425     "dumpxml",
 426       cmd1 print_endline D.get_xml_desc
 427         (arg_full_connection domain_of_string),
 428       "Print the XML description of a domain.";
 429     "get-autostart",
 430       cmd1 print_bool D.get_autostart
 431         (arg_readonly_connection domain_of_string),
 432       "Print whether a domain autostarts at boot.";
 433     "hostname",
 434       cmd0 print_endline (with_readonly_connection C.get_hostname),
 435       "Print the hostname.";
 436     "list",
 437       cmd0 print_domain_array
 438         (fun () ->
 439            let c = get_readonly_connection () in
 440            let n = C.num_of_domains c in
 441            let domids = C.list_domains c n in
 442            Array.map (D.lookup_by_id c) domids),
 443       "List the running domains.";
 444     "list-defined",
 445       cmd0 print_domain_array
 446         (fun () ->
 447            let c = get_readonly_connection () in
 448            let n = C.num_of_defined_domains c in
 449            let domnames = C.list_defined_domains c n in
 450            Array.map (D.lookup_by_name c) domnames),
 451       "List the defined but not running domains.";
 452     "quit",
 453       cmd0 no_return (fun () -> exit 0),
 454       "Quit the interactive terminal.";
 455     "maxvcpus",
 456       cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()),
 457       "Print the max VCPUs available.";
 458     "net-autostart",
 459       cmd2 no_return N.set_autostart
 460         (arg_full_connection network_of_string) boolean_of_string,
 461       "Set whether a network autostarts at boot.";
 462     "net-bridgename",
 463       cmd1 print_endline N.get_bridge_name
 464         (arg_readonly_connection network_of_string),
 465       "Print the bridge name of a network.";
 466     "net-create",
 467       cmd1 no_return
 468         (fun xml -> N.create_xml (get_full_connection ()) xml) input_file,
 469       "Create a network from an XML file.";
 470     "net-define",
 471       cmd1 no_return
 472         (fun xml -> N.define_xml (get_full_connection ()) xml) input_file,
 473       "Define (but don't start) a network from an XML file.";
 474     "net-destroy",
 475       cmd1 no_return N.destroy (arg_full_connection network_of_string),
 476       "Destroy a network.";
 477     "net-dumpxml",
 478       cmd1 print_endline N.get_xml_desc
 479         (arg_full_connection network_of_string),
 480       "Print the XML description of a network.";
 481     "net-get-autostart",
 482       cmd1 print_bool N.get_autostart
 483         (arg_full_connection network_of_string),
 484       "Print whether a network autostarts at boot.";
 485     "net-list",
 486       cmd0 print_network_array
 487         (fun () ->
 488            let c = get_readonly_connection () in
 489            let n = C.num_of_networks c in
 490            let nets = C.list_networks c n in
 491            Array.map (N.lookup_by_name c) nets),
 492       "List the active networks.";
 493     "net-list-defined",
 494       cmd0 print_network_array
 495         (fun () ->
 496            let c = get_readonly_connection () in
 497            let n = C.num_of_defined_networks c in
 498            let nets = C.list_defined_networks c n in
 499            Array.map (N.lookup_by_name c) nets),
 500       "List the defined but inactive networks.";
 501     "net-name",
 502       cmd1 print_endline N.get_name
 503         (arg_readonly_connection network_of_string),
 504       "Print the name of a network.";
 505     "net-start",
 506       cmd1 no_return N.create
 507         (arg_full_connection network_of_string),
 508       "Start a previously defined inactive network.";
 509     "net-undefine",
 510       cmd1 no_return N.undefine
 511         (arg_full_connection network_of_string),
 512       "Undefine an inactive network.";
 513     "net-uuid",
 514       cmd1 print_endline N.get_uuid_string
 515         (arg_readonly_connection network_of_string),
 516       "Print the UUID of a network.";
 517     "nodeinfo",
 518       cmd0 print_node_info (with_readonly_connection C.get_node_info),
 519       "Print node information.";
 520     "reboot",
 521       cmd1 no_return D.reboot (arg_full_connection domain_of_string),
 522       "Reboot a domain.";
 523     "restore",
 524       cmd1 no_return (
 525         fun path -> D.restore (get_full_connection ()) path
 526         ) string_of_string,
 527       "Restore a domain from the named file.";
 528     "resume",
 529       cmd1 no_return D.resume (arg_full_connection domain_of_string),
 530       "Resume a domain.";
 531     "save",
 532       cmd2 no_return D.save
 533         (arg_full_connection domain_of_string) string_of_string,
 534       "Save a domain to a file.";
 535     "schedparams",
 536       cmd1 print_sched_param_array (
 537         fun dom ->
 538           let n = snd (D.get_scheduler_type dom) in
 539           D.get_scheduler_parameters dom n
 540         ) (arg_readonly_connection domain_of_string),
 541       "Get the current scheduler parameters for a domain.";
 542     "schedparamset",
 543       cmdN no_return (
 544         function
 545         | [] -> failwith "expecting domain followed by field value pairs"
 546         | dom :: pairs ->
 547             let conn = get_full_connection () in
 548             let dom = domain_of_string conn dom in
 549             let params = parse_sched_params pairs in
 550             let params = Array.of_list params in
 551             D.set_scheduler_parameters dom params
 552         ),
 553       "Set the scheduler parameters for a domain.";
 554     "schedtype",
 555       cmd1 print_endline
 556         (fun dom -> fst (D.get_scheduler_type dom))
 557         (arg_readonly_connection domain_of_string),
 558       "Get the scheduler type.";
 559     "setmem",
 560       cmd2 no_return D.set_memory
 561         (arg_full_connection domain_of_string) Int64.of_string,
 562       "Set the memory used by the domain (in kilobytes).";
 563     "setmaxmem",
 564       cmd2 no_return D.set_max_memory
 565         (arg_full_connection domain_of_string) Int64.of_string,
 566       "Set the maximum memory used by the domain (in kilobytes).";
 567     "shutdown",
 568       cmd1 no_return D.shutdown
 569         (arg_full_connection domain_of_string),
 570       "Gracefully shutdown a domain.";
 571     "start",
 572       cmd1 no_return D.create
 573         (arg_full_connection domain_of_string),
 574       "Start a previously defined inactive domain.";
 575     "suspend",
 576       cmd1 no_return D.suspend
 577         (arg_full_connection domain_of_string),
 578       "Suspend a domain.";
 579     "type",
 580       cmd0 print_endline (with_readonly_connection C.get_type),
 581       "Print the driver name";
 582     "undefine",
 583       cmd1 no_return D.undefine
 584         (arg_full_connection domain_of_string),
 585       "Undefine an inactive domain.";
 586     "uri",
 587       cmd0 print_endline (with_readonly_connection C.get_uri),
 588       "Print the canonical URI.";
 589     "vcpuinfo",
 590       cmd1 print_vcpu_info (
 591         fun dom ->
 592           let c = get_readonly_connection () in
 593           let info = C.get_node_info c in
 594           let dominfo = D.get_info dom in
 595           let maxcpus = C.maxcpus_of_node_info info in
 596           let maplen = C.cpumaplen maxcpus in
 597           let maxinfo = dominfo.D.nr_virt_cpu in
 598           let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in
 599           ncpus, vcpu_infos, cpumaps, maplen, maxcpus
 600         ) (arg_readonly_connection domain_of_string),
 601       "Pin domain VCPU to a list of physical CPUs.";
 602     "vcpupin",
 603       cmd3 no_return D.pin_vcpu
 604         (arg_full_connection domain_of_string) int_of_string cpumap_of_string,
 605       "Pin domain VCPU to a list of physical CPUs.";
 606     "vcpus",
 607       cmd2 no_return D.set_vcpus
 608         (arg_full_connection domain_of_string) int_of_string,
 609       "Set the number of virtual CPUs assigned to a domain.";
 610     "version",
 611       cmd0 print_version (with_readonly_connection C.get_version),
 612       "Print the driver version";
 613   ] in
 614
 615   (* Command help. *)
 616   let help = function
 617     | None ->                           (* List of commands. *)
 618         String.concat "\n" (
 619           List.map (
 620             fun (cmd, _, description) ->
 621               sprintf "%-12s %s" cmd description
 622           ) commands
 623         ) ^
 624         "\n\nUse '" ^ program_name ^ " help command' for help on a command."
 625
 626     | Some command ->                   (* Full description of one command. *)
 627         try
 628           let (command, _, description) =
 629             List.find (fun (c, _, _) -> c = command) commands in
 630           sprintf "%s %s\n\n%s" program_name command description
 631         with
 632           Not_found ->
 633             failwith ("help: " ^ command ^ ": command not found");
 634   in
 635
 636   let commands =
 637     ("help",
 638      cmd01 print_endline help string_of_string,
 639      "Print list of commands or full description of one command.";
 640     ) :: commands in
 641
 642   (* Execute a command. *)
 643   let do_command command args =
 644     try
 645       let (_, cmd, _) = List.find (fun (c, _, _) -> c = command) commands in
 646       cmd args
 647     with
 648       Not_found ->
 649         failwith (command ^ ": command not found");
 650   in
 651
 652   do_command
 653
 654 (* Interactive mode. *)
 655 let rec interactive_mode () =
 656   let prompt =
 657     match !conn with
 658     | No_connection -> "mlvirsh(no connection)$ "
 659     | RO _ -> "mlvirsh(ro)$ "
 660     | RW _ -> "mlvirsh# " in
 661   print_string prompt;
 662   let command = read_line () in
 663   (match String.nsplit command " " with
 664    | [] -> ()
 665    | command :: args ->
 666        do_command command args
 667   );
 668   Gc.full_major (); (* Free up all unreachable domain and network objects. *)
 669   interactive_mode ()
 670
 671 (* Connect to hypervisor.  Allow the connection to fail. *)
 672 let () =
 673   conn :=
 674     try
 675       if readonly then RO (C.connect_readonly ?name ())
 676       else RW (C.connect ?name ())
 677     with
 678       Libvirt.Virterror err ->
 679         eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err);
 680         No_connection
 681
 682 let () =
 683   try
 684     (* Execute the command on the command line, if there was one.
 685      * Otherwise go into interactive mode.
 686      *)
 687     (match extra_args with
 688      | command :: args ->
 689          do_command command args
 690      | [] ->
 691          try interactive_mode () with End_of_file -> ()
 692     );
 693
 694     (* If we are connected to a hypervisor, close the connection. *)
 695     close_connection ();
 696
 697     (* A good way to find heap bugs: *)
 698     Gc.compact ()
 699   with
 700   | Libvirt.Virterror err ->
 701       eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err)
 702   | Failure msg ->
 703       eprintf "%s: %s\n" program_name msg