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