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