mlvirsh/mlvirsh.ml

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