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 cmd012 print fn arg1 arg2 = function (* Command with 0, 1 or 2 args. *)
 142     | [] -> print (fn None None)
 143     | [str1] -> print (fn (Some (arg1 str1)) None)
 144     | [str1; str2] -> print (fn (Some (arg1 str1)) (Some (arg2 str2)))
 145     | _ -> failwith "incorrect number of arguments for function"
 146   in
 147   let cmdN print fn =           (* Command with any number of args. *)
 148     fun args -> print (fn args)
 149   in
 150
 151   (* Get the connection or fail if we don't have one. *)
 152   let rec get_full_connection () =
 153     match !conn with
 154     | No_connection -> failwith "not connected to the hypervisor"
 155     | RO _ -> failwith "tried to do read-write operation on read-only hypervisor connection"
 156     | RW conn -> conn
 157   and get_readonly_connection () =
 158     match !conn with
 159     | No_connection -> failwith "not connected to the hypervisor"
 160     | RO conn -> conn
 161     | RW conn -> C.const conn
 162 (*
 163   and with_full_connection fn =
 164     fun () -> fn (get_full_connection ())
 165 *)
 166   and with_readonly_connection fn =
 167     fun () -> fn (get_readonly_connection ())
 168   and arg_full_connection fn =
 169     fun str -> fn (get_full_connection ()) str
 170   and arg_readonly_connection fn =
 171     fun str -> fn (get_readonly_connection ()) str
 172   in
 173
 174   (* Parsing of command arguments. *)
 175   let string_of_readonly = function
 176     | "readonly" | "read-only" | "ro" -> true
 177     | _ -> failwith "flag should be 'readonly'"
 178   in
 179   let string_of_string (str : string) = str in
 180   let boolean_of_string = function
 181     | "enable" | "enabled" | "on" | "1" | "true" -> true
 182     | "disable" | "disabled" | "off" | "0" | "false" -> false
 183     | _ -> failwith "setting should be 'on' or 'off'"
 184   in
 185   let domain_of_string conn str =
 186     try
 187       (try
 188          let id = int_of_string str in
 189          D.lookup_by_id conn id
 190        with
 191          Failure "int_of_string" ->
 192            if String.length str = Libvirt.uuid_string_length then
 193              D.lookup_by_uuid_string conn str
 194            else
 195              D.lookup_by_name conn str
 196       )
 197     with
 198       Libvirt.Virterror err ->
 199         failwith ("domain " ^ str ^ ": not found.  Additional info: " ^
 200                     Libvirt.Virterror.to_string err);
 201   in
 202   let network_of_string conn str =
 203     try
 204       if String.length str = Libvirt.uuid_string_length then
 205         N.lookup_by_uuid_string conn str
 206       else
 207         N.lookup_by_name conn str
 208     with
 209       Libvirt.Virterror err ->
 210         failwith ("network " ^ str ^ ": not found.  Additional info: " ^
 211                     Libvirt.Virterror.to_string err);
 212   in
 213   let rec parse_sched_params = function
 214     | [] -> []
 215     | [_] -> failwith "expected field value pairs, but got an odd number of arguments"
 216     | field :: value :: rest ->
 217         (* XXX We only support the UINT type at the moment. *)
 218         (field, D.SchedFieldUInt32 (Int32.of_string value))
 219           :: parse_sched_params rest
 220   in
 221   let cpumap_of_string str =
 222     let c = get_readonly_connection () in
 223     let info = C.get_node_info c in
 224     let cpumap =
 225       String.make (C.cpumaplen (C.maxcpus_of_node_info info)) '\000' in
 226     List.iter (C.use_cpu cpumap)
 227       (List.map int_of_string (String.nsplit str ","));
 228     cpumap
 229   in
 230
 231   (* Printing of command results. *)
 232   let no_return _ = () in
 233   let print_int i = print_endline (string_of_int i) in
 234   let print_int64 i = print_endline (Int64.to_string i) in
 235   let print_int64_array a = Array.iter print_int64 a in
 236   let print_bool b = print_endline (string_of_bool b) in
 237   let print_version v =
 238     let major = v / 1000000 in
 239     let minor = (v - major * 1000000) / 1000 in
 240     let release = (v - major * 1000000 - minor * 1000) in
 241     printf "%d.%d.%d\n" major minor release
 242   in
 243   let string_of_domain_state = function
 244     | D.InfoNoState -> "unknown"
 245     | D.InfoRunning -> "running"
 246     | D.InfoBlocked -> "blocked"
 247     | D.InfoPaused -> "paused"
 248     | D.InfoShutdown -> "shutdown"
 249     | D.InfoShutoff -> "shutoff"
 250     | D.InfoCrashed -> "crashed"
 251   in
 252   let string_of_vcpu_state = function
 253     | D.VcpuOffline -> "offline"
 254     | D.VcpuRunning -> "running"
 255     | D.VcpuBlocked -> "blocked"
 256   in
 257   let print_domain_array doms =
 258     Array.iter (
 259       fun dom ->
 260         let id =
 261           try sprintf "%d" (D.get_id dom)
 262           with Libvirt.Virterror _ -> "" in
 263         let name =
 264           try sprintf "%s" (D.get_name dom)
 265           with Libvirt.Virterror _ -> "" in
 266         let state =
 267           try
 268             let { D.state = state } = D.get_info dom in
 269             string_of_domain_state state
 270           with Libvirt.Virterror _ -> "" in
 271         printf "%5s %-30s %s\n" id name state
 272     ) doms
 273   in
 274   let print_network_array nets =
 275     Array.iter (
 276       fun net ->
 277         printf "%s\n" (N.get_name net)
 278     ) nets
 279   in
 280   let print_node_info info =
 281     printf "model:   %s\n" info.C.model;
 282     printf "memory:  %Ld K\n" info.C.memory;
 283     printf "cpus:    %d\n" info.C.cpus;
 284     printf "mhz:     %d\n" info.C.mhz;
 285     printf "nodes:   %d\n" info.C.nodes;
 286     printf "sockets: %d\n" info.C.sockets;
 287     printf "cores:   %d\n" info.C.cores;
 288     printf "threads: %d\n" info.C.threads;
 289   in
 290   let print_domain_state { D.state = state } =
 291     print_endline (string_of_domain_state state)
 292   in
 293   let print_domain_info info =
 294     printf "state:       %s\n" (string_of_domain_state info.D.state);
 295     printf "max_mem:     %Ld K\n" info.D.max_mem;
 296     printf "memory:      %Ld K\n" info.D.memory;
 297     printf "nr_virt_cpu: %d\n" info.D.nr_virt_cpu;
 298     printf "cpu_time:    %Ld ns\n" info.D.cpu_time;
 299   in
 300   let print_sched_param_array params =
 301     Array.iter (
 302       fun (name, value) ->
 303         printf "%-20s" name;
 304         match value with
 305         | D.SchedFieldInt32 i -> printf " %ld\n" i
 306         | D.SchedFieldUInt32 i -> printf " %lu\n" i
 307         | D.SchedFieldInt64 i -> printf " %Ld\n" i
 308         | D.SchedFieldUInt64 i -> printf " %Lu\n" i
 309         | D.SchedFieldFloat f -> printf " %g\n" f
 310         | D.SchedFieldBool b -> printf " %b\n" b
 311     ) params
 312   in
 313   let print_vcpu_info (ncpus, vcpu_infos, cpumaps, maplen, maxcpus) =
 314     for n = 0 to ncpus-1 do
 315       printf "virtual CPU: %d\n" n;
 316       printf "  on physical CPU: %d\n" vcpu_infos.(n).D.cpu;
 317       printf "  current state:   %s\n"
 318         (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state);
 319       printf "  CPU time:        %Ld ns\n" vcpu_infos.(n).D.vcpu_time;
 320       printf "  CPU affinity:    ";
 321       for m = 0 to maxcpus-1 do
 322         print_char (if C.cpu_usable cpumaps maplen n m then 'y' else '-')
 323       done;
 324       print_endline "";
 325     done
 326   in
 327   let print_block_stats { D.rd_req = rd_req; rd_bytes = rd_bytes;
 328                           wr_req = wr_req; wr_bytes = wr_bytes;
 329                           errs = errs } =
 330     if rd_req >= 0L then   printf "read requests:  %Ld\n" rd_req;
 331     if rd_bytes >= 0L then printf "read bytes:     %Ld\n" rd_bytes;
 332     if wr_req >= 0L then   printf "write requests: %Ld\n" wr_req;
 333     if wr_bytes >= 0L then printf "write bytes:    %Ld\n" wr_bytes;
 334     if errs >= 0L then     printf "errors:         %Ld\n" errs;
 335   and print_interface_stats { D.rx_bytes = rx_bytes; rx_packets = rx_packets;
 336                               rx_errs = rx_errs; rx_drop = rx_drop;
 337                               tx_bytes = tx_bytes; tx_packets = tx_packets;
 338                               tx_errs = tx_errs; tx_drop = tx_drop } =
 339     if rx_bytes >= 0L then   printf "rx bytes:   %Ld\n" rx_bytes;
 340     if rx_packets >= 0L then printf "rx packets: %Ld\n" rx_packets;
 341     if rx_errs >= 0L then    printf "rx errs:    %Ld\n" rx_errs;
 342     if rx_drop >= 0L then    printf "rx dropped: %Ld\n" rx_drop;
 343     if tx_bytes >= 0L then   printf "tx bytes:   %Ld\n" tx_bytes;
 344     if tx_packets >= 0L then printf "tx packets: %Ld\n" tx_packets;
 345     if tx_errs >= 0L then    printf "tx errs:    %Ld\n" tx_errs;
 346     if tx_drop >= 0L then    printf "tx dropped: %Ld\n" tx_drop;
 347   in
 348
 349   (* List of commands. *)
 350   let commands = [
 351     "attach-device",
 352       cmd2 no_return D.attach_device
 353         (arg_full_connection domain_of_string) input_file,
 354       "Attach device to domain.";
 355     "autostart",
 356       cmd2 no_return D.set_autostart
 357         (arg_full_connection domain_of_string) boolean_of_string,
 358       "Set whether a domain autostarts at boot.";
 359     "capabilities",
 360       cmd0 print_endline (with_readonly_connection C.get_capabilities),
 361       "Returns capabilities of hypervisor/driver.";
 362     "close",
 363       cmd0 no_return close_connection,
 364       "Close an existing hypervisor connection.";
 365     "connect",
 366       cmd12 no_return
 367         (fun name readonly ->
 368            close_connection ();
 369            match readonly with
 370            | None | Some false -> conn := RW (C.connect ~name ())
 371            | Some true -> conn := RO (C.connect_readonly ~name ())
 372         ) string_of_string string_of_readonly,
 373       "Open a new hypervisor connection.";
 374     "create",
 375       cmd1 no_return
 376         (fun xml -> D.create_linux (get_full_connection ()) xml) input_file,
 377       "Create a domain from an XML file.";
 378     "define",
 379       cmd1 no_return
 380         (fun xml -> D.define_xml (get_full_connection ()) xml) input_file,
 381       "Define (but don't start) a domain from an XML file.";
 382     "detach-device",
 383       cmd2 no_return D.detach_device
 384         (arg_full_connection domain_of_string) input_file,
 385       "Detach device from domain.";
 386     "destroy",
 387       cmd1 no_return D.destroy (arg_full_connection domain_of_string),
 388       "Destroy a domain.";
 389     "domblkstat",
 390       cmd2 print_block_stats D.block_stats
 391         (arg_readonly_connection domain_of_string) string_of_string,
 392       "Display the block device statistics for a domain.";
 393     "domid",
 394       cmd1 print_int D.get_id (arg_readonly_connection domain_of_string),
 395       "Print the ID of a domain.";
 396     "domifstat",
 397       cmd2 print_interface_stats D.interface_stats
 398         (arg_readonly_connection domain_of_string) string_of_string,
 399       "Display the network interface statistics for a domain.";
 400     "dominfo",
 401       cmd1 print_domain_info D.get_info
 402         (arg_readonly_connection domain_of_string),
 403       "Print the domain info.";
 404     "dommaxmem",
 405       cmd1 print_int64 D.get_max_memory
 406         (arg_readonly_connection domain_of_string),
 407       "Print the max memory (in kilobytes) of a domain.";
 408     "dommaxvcpus",
 409       cmd1 print_int D.get_max_vcpus
 410         (arg_readonly_connection domain_of_string),
 411       "Print the max VCPUs of a domain.";
 412     "domname",
 413       cmd1 print_endline D.get_name
 414         (arg_readonly_connection domain_of_string),
 415       "Print the name of a domain.";
 416     "domostype",
 417       cmd1 print_endline D.get_os_type
 418         (arg_readonly_connection domain_of_string),
 419       "Print the OS type of a domain.";
 420     "domstate",
 421       cmd1 print_domain_state D.get_info
 422         (arg_readonly_connection domain_of_string),
 423       "Print the domain state.";
 424     "domuuid",
 425       cmd1 print_endline D.get_uuid_string
 426         (arg_readonly_connection domain_of_string),
 427       "Print the UUID of a domain.";
 428     "dump",
 429       cmd2 no_return D.core_dump
 430         (arg_full_connection domain_of_string) string_of_string,
 431       "Core dump a domain to a file for analysis.";
 432     "dumpxml",
 433       cmd1 print_endline D.get_xml_desc
 434         (arg_full_connection domain_of_string),
 435       "Print the XML description of a domain.";
 436     "freecell",
 437       cmd012 print_int64_array (
 438         fun start max ->
 439           let conn = get_readonly_connection () in
 440           match start, max with
 441           | None, _ ->
 442               [| C.node_get_free_memory conn |]
 443           | Some start, None ->
 444               C.node_get_cells_free_memory conn start 1
 445           | Some start, Some max ->
 446               C.node_get_cells_free_memory conn start max
 447           ) int_of_string int_of_string,
 448       "Display free memory for machine, NUMA cell or range of cells";
 449     "get-autostart",
 450       cmd1 print_bool D.get_autostart
 451         (arg_readonly_connection domain_of_string),
 452       "Print whether a domain autostarts at boot.";
 453     "hostname",
 454       cmd0 print_endline (with_readonly_connection C.get_hostname),
 455       "Print the hostname.";
 456     "list",
 457       cmd0 print_domain_array
 458         (fun () ->
 459            let c = get_readonly_connection () in
 460            let n = C.num_of_domains c in
 461            let domids = C.list_domains c n in
 462            Array.map (D.lookup_by_id c) domids),
 463       "List the running domains.";
 464     "list-defined",
 465       cmd0 print_domain_array
 466         (fun () ->
 467            let c = get_readonly_connection () in
 468            let n = C.num_of_defined_domains c in
 469            let domnames = C.list_defined_domains c n in
 470            Array.map (D.lookup_by_name c) domnames),
 471       "List the defined but not running domains.";
 472     "quit",
 473       cmd0 no_return (fun () -> exit 0),
 474       "Quit the interactive terminal.";
 475     "maxvcpus",
 476       cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()),
 477       "Print the max VCPUs available.";
 478     "net-autostart",
 479       cmd2 no_return N.set_autostart
 480         (arg_full_connection network_of_string) boolean_of_string,
 481       "Set whether a network autostarts at boot.";
 482     "net-bridgename",
 483       cmd1 print_endline N.get_bridge_name
 484         (arg_readonly_connection network_of_string),
 485       "Print the bridge name of a network.";
 486     "net-create",
 487       cmd1 no_return
 488         (fun xml -> N.create_xml (get_full_connection ()) xml) input_file,
 489       "Create a network from an XML file.";
 490     "net-define",
 491       cmd1 no_return
 492         (fun xml -> N.define_xml (get_full_connection ()) xml) input_file,
 493       "Define (but don't start) a network from an XML file.";
 494     "net-destroy",
 495       cmd1 no_return N.destroy (arg_full_connection network_of_string),
 496       "Destroy a network.";
 497     "net-dumpxml",
 498       cmd1 print_endline N.get_xml_desc
 499         (arg_full_connection network_of_string),
 500       "Print the XML description of a network.";
 501     "net-get-autostart",
 502       cmd1 print_bool N.get_autostart
 503         (arg_full_connection network_of_string),
 504       "Print whether a network autostarts at boot.";
 505     "net-list",
 506       cmd0 print_network_array
 507         (fun () ->
 508            let c = get_readonly_connection () in
 509            let n = C.num_of_networks c in
 510            let nets = C.list_networks c n in
 511            Array.map (N.lookup_by_name c) nets),
 512       "List the active networks.";
 513     "net-list-defined",
 514       cmd0 print_network_array
 515         (fun () ->
 516            let c = get_readonly_connection () in
 517            let n = C.num_of_defined_networks c in
 518            let nets = C.list_defined_networks c n in
 519            Array.map (N.lookup_by_name c) nets),
 520       "List the defined but inactive networks.";
 521     "net-name",
 522       cmd1 print_endline N.get_name
 523         (arg_readonly_connection network_of_string),
 524       "Print the name of a network.";
 525     "net-start",
 526       cmd1 no_return N.create
 527         (arg_full_connection network_of_string),
 528       "Start a previously defined inactive network.";
 529     "net-undefine",
 530       cmd1 no_return N.undefine
 531         (arg_full_connection network_of_string),
 532       "Undefine an inactive network.";
 533     "net-uuid",
 534       cmd1 print_endline N.get_uuid_string
 535         (arg_readonly_connection network_of_string),
 536       "Print the UUID of a network.";
 537     "nodeinfo",
 538       cmd0 print_node_info (with_readonly_connection C.get_node_info),
 539       "Print node information.";
 540     "reboot",
 541       cmd1 no_return D.reboot (arg_full_connection domain_of_string),
 542       "Reboot a domain.";
 543     "restore",
 544       cmd1 no_return (
 545         fun path -> D.restore (get_full_connection ()) path
 546         ) string_of_string,
 547       "Restore a domain from the named file.";
 548     "resume",
 549       cmd1 no_return D.resume (arg_full_connection domain_of_string),
 550       "Resume a domain.";
 551     "save",
 552       cmd2 no_return D.save
 553         (arg_full_connection domain_of_string) string_of_string,
 554       "Save a domain to a file.";
 555     "schedparams",
 556       cmd1 print_sched_param_array (
 557         fun dom ->
 558           let n = snd (D.get_scheduler_type dom) in
 559           D.get_scheduler_parameters dom n
 560         ) (arg_readonly_connection domain_of_string),
 561       "Get the current scheduler parameters for a domain.";
 562     "schedparamset",
 563       cmdN no_return (
 564         function
 565         | [] -> failwith "expecting domain followed by field value pairs"
 566         | dom :: pairs ->
 567             let conn = get_full_connection () in
 568             let dom = domain_of_string conn dom in
 569             let params = parse_sched_params pairs in
 570             let params = Array.of_list params in
 571             D.set_scheduler_parameters dom params
 572         ),
 573       "Set the scheduler parameters for a domain.";
 574     "schedtype",
 575       cmd1 print_endline
 576         (fun dom -> fst (D.get_scheduler_type dom))
 577         (arg_readonly_connection domain_of_string),
 578       "Get the scheduler type.";
 579     "setmem",
 580       cmd2 no_return D.set_memory
 581         (arg_full_connection domain_of_string) Int64.of_string,
 582       "Set the memory used by the domain (in kilobytes).";
 583     "setmaxmem",
 584       cmd2 no_return D.set_max_memory
 585         (arg_full_connection domain_of_string) Int64.of_string,
 586       "Set the maximum memory used by the domain (in kilobytes).";
 587     "shutdown",
 588       cmd1 no_return D.shutdown
 589         (arg_full_connection domain_of_string),
 590       "Gracefully shutdown a domain.";
 591     "start",
 592       cmd1 no_return D.create
 593         (arg_full_connection domain_of_string),
 594       "Start a previously defined inactive domain.";
 595     "suspend",
 596       cmd1 no_return D.suspend
 597         (arg_full_connection domain_of_string),
 598       "Suspend a domain.";
 599     "type",
 600       cmd0 print_endline (with_readonly_connection C.get_type),
 601       "Print the driver name";
 602     "undefine",
 603       cmd1 no_return D.undefine
 604         (arg_full_connection domain_of_string),
 605       "Undefine an inactive domain.";
 606     "uri",
 607       cmd0 print_endline (with_readonly_connection C.get_uri),
 608       "Print the canonical URI.";
 609     "vcpuinfo",
 610       cmd1 print_vcpu_info (
 611         fun dom ->
 612           let c = get_readonly_connection () in
 613           let info = C.get_node_info c in
 614           let dominfo = D.get_info dom in
 615           let maxcpus = C.maxcpus_of_node_info info in
 616           let maplen = C.cpumaplen maxcpus in
 617           let maxinfo = dominfo.D.nr_virt_cpu in
 618           let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in
 619           ncpus, vcpu_infos, cpumaps, maplen, maxcpus
 620         ) (arg_readonly_connection domain_of_string),
 621       "Pin domain VCPU to a list of physical CPUs.";
 622     "vcpupin",
 623       cmd3 no_return D.pin_vcpu
 624         (arg_full_connection domain_of_string) int_of_string cpumap_of_string,
 625       "Pin domain VCPU to a list of physical CPUs.";
 626     "vcpus",
 627       cmd2 no_return D.set_vcpus
 628         (arg_full_connection domain_of_string) int_of_string,
 629       "Set the number of virtual CPUs assigned to a domain.";
 630     "version",
 631       cmd0 print_version (with_readonly_connection C.get_version),
 632       "Print the driver version";
 633   ] in
 634
 635   (* Command help. *)
 636   let help = function
 637     | None ->                           (* List of commands. *)
 638         String.concat "\n" (
 639           List.map (
 640             fun (cmd, _, description) ->
 641               sprintf "%-12s %s" cmd description
 642           ) commands
 643         ) ^
 644         "\n\nUse '" ^ program_name ^ " help command' for help on a command."
 645
 646     | Some command ->                   (* Full description of one command. *)
 647         try
 648           let (command, _, description) =
 649             List.find (fun (c, _, _) -> c = command) commands in
 650           sprintf "%s %s\n\n%s" program_name command description
 651         with
 652           Not_found ->
 653             failwith ("help: " ^ command ^ ": command not found");
 654   in
 655
 656   let commands =
 657     ("help",
 658      cmd01 print_endline help string_of_string,
 659      "Print list of commands or full description of one command.";
 660     ) :: commands in
 661
 662   (* Execute a command. *)
 663   let do_command command args =
 664     try
 665       let (_, cmd, _) = List.find (fun (c, _, _) -> c = command) commands in
 666       cmd args
 667     with
 668       Not_found ->
 669         failwith (command ^ ": command not found");
 670   in
 671
 672   do_command
 673
 674 (* Interactive mode. *)
 675 let rec interactive_mode () =
 676   let prompt =
 677     match !conn with
 678     | No_connection -> "mlvirsh(no connection)$ "
 679     | RO _ -> "mlvirsh(ro)$ "
 680     | RW _ -> "mlvirsh# " in
 681   print_string prompt;
 682   let command = read_line () in
 683   (match String.nsplit command " " with
 684    | [] -> ()
 685    | command :: args ->
 686        do_command command args
 687   );
 688   Gc.full_major (); (* Free up all unreachable domain and network objects. *)
 689   interactive_mode ()
 690
 691 (* Connect to hypervisor.  Allow the connection to fail. *)
 692 let () =
 693   conn :=
 694     try
 695       if readonly then RO (C.connect_readonly ?name ())
 696       else RW (C.connect ?name ())
 697     with
 698       Libvirt.Virterror err ->
 699         eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err);
 700         No_connection
 701
 702 let () =
 703   try
 704     (* Execute the command on the command line, if there was one.
 705      * Otherwise go into interactive mode.
 706      *)
 707     (match extra_args with
 708      | command :: args ->
 709          do_command command args
 710      | [] ->
 711          try interactive_mode () with End_of_file -> ()
 712     );
 713
 714     (* If we are connected to a hypervisor, close the connection. *)
 715     close_connection ();
 716
 717     (* A good way to find heap bugs: *)
 718     Gc.compact ()
 719   with
 720   | Libvirt.Virterror err ->
 721       eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err)
 722   | Failure msg ->
 723       eprintf "%s: %s\n" program_name msg