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