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