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_list doms =
 306     List.iter (
 307       fun (dom, info) ->
 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 } = info 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            let max_peek = D.max_peek dom in
 458            let rec loop i =
 459              let remaining = size-i in
 460              if remaining > 0 then (
 461                let size = min remaining max_peek in
 462                D.block_peek dom path
 463                  (Int64.add offset (Int64.of_int i)) size buf i;
 464                loop (i+size)
 465              )
 466            in
 467            loop 0;
 468            buf)
 469         (arg_readonly_connection domain_of_string)
 470         string_of_string Int64.of_string int_of_string,
 471       s_"Peek into a block device of a domain.",
 472       [dom_help; s_"path",s_"Path to block device";
 473        s_"offset",s_"Offset in device"; s_"size",s_"Size in bytes to read"];
 474     "domblkstat",
 475       cmd2 print_block_stats D.block_stats
 476         (arg_readonly_connection domain_of_string) string_of_string,
 477       s_"Display the block device statistics for a domain.",
 478       [dom_help; s_"path",s_"Path to block device"];
 479     "domid",
 480       cmd1 print_int D.get_id (arg_readonly_connection domain_of_string),
 481       s_"Print the ID of a domain.",
 482       [dom_help];
 483     "domifstat",
 484       cmd2 print_interface_stats D.interface_stats
 485         (arg_readonly_connection domain_of_string) string_of_string,
 486       s_"Display the network interface statistics for a domain.",
 487       [dom_help; s_"path",s_"Path or name of network interface"];
 488     "dominfo",
 489       cmd1 print_domain_info D.get_info
 490         (arg_readonly_connection domain_of_string),
 491       s_"Print the domain info.",
 492       [dom_help];
 493     "dommaxmem",
 494       cmd1 print_int64 D.get_max_memory
 495         (arg_readonly_connection domain_of_string),
 496       s_"Print the max memory (in kilobytes) of a domain.",
 497       [dom_help];
 498     "dommaxvcpus",
 499       cmd1 print_int D.get_max_vcpus
 500         (arg_readonly_connection domain_of_string),
 501       s_"Print the max VCPUs of a domain.",
 502       [dom_help];
 503     "dommempeek",
 504       cmd3 print_string
 505         (fun dom offset size ->
 506            let buf = String.create size in
 507            let max_peek = D.max_peek dom in
 508            let rec loop i =
 509              let remaining = size-i in
 510              if remaining > 0 then (
 511                let size = min remaining max_peek in
 512                D.memory_peek dom [D.Virtual]
 513                  (Int64.add offset (Int64.of_int i)) size buf i;
 514                loop (i+size)
 515              )
 516            in
 517            loop 0;
 518            buf)
 519         (arg_readonly_connection domain_of_string)
 520         Int64.of_string int_of_string,
 521       s_"Peek into memory of a device.",
 522       [dom_help; s_"offset",s_"Offset in memory";
 523        s_"size",s_"Size in bytes to read"];
 524     "domname",
 525       cmd1 print_endline D.get_name
 526         (arg_readonly_connection domain_of_string),
 527       s_"Print the name of a domain.",
 528       [dom_help];
 529     "domostype",
 530       cmd1 print_endline D.get_os_type
 531         (arg_readonly_connection domain_of_string),
 532       s_"Print the OS type of a domain.",
 533       [dom_help];
 534     "domstate",
 535       cmd1 print_domain_state D.get_info
 536         (arg_readonly_connection domain_of_string),
 537       s_"Print the domain state.",
 538       [dom_help];
 539     "domuuid",
 540       cmd1 print_endline D.get_uuid_string
 541         (arg_readonly_connection domain_of_string),
 542       s_"Print the UUID of a domain.",
 543       [dom_help];
 544     "dump",
 545       cmd2 no_return D.core_dump
 546         (arg_full_connection domain_of_string) string_of_string,
 547       s_"Core dump a domain to a file for analysis.",
 548       [dom_help; s_"file",s_"Output filename"];
 549     "dumpxml",
 550       cmd1 print_endline D.get_xml_desc
 551         (arg_full_connection domain_of_string),
 552       s_"Print the XML description of a domain.",
 553       [dom_help];
 554     "freecell",
 555       cmd012 print_int64_array (
 556         fun start max ->
 557           let conn = get_readonly_connection () in
 558           match start, max with
 559           | None, _ ->
 560               [| C.node_get_free_memory conn |]
 561           | Some start, None ->
 562               C.node_get_cells_free_memory conn start 1
 563           | Some start, Some max ->
 564               C.node_get_cells_free_memory conn start max
 565           ) int_of_string int_of_string,
 566       s_"Display free memory for machine, NUMA cell or range of cells",
 567       [s_"start",s_"Start cell (optional)";
 568        s_"max",s_"Maximum cells to display (optional)"];
 569     "get-autostart",
 570       cmd1 print_bool D.get_autostart
 571         (arg_readonly_connection domain_of_string),
 572       s_"Print whether a domain autostarts at boot.",
 573       [dom_help];
 574     "hostname",
 575       cmd0 print_endline (with_readonly_connection C.get_hostname),
 576       s_"Print the hostname.",
 577       [];
 578     "list",
 579       cmd0 print_domain_list
 580         (fun () ->
 581            let c = get_readonly_connection () in
 582            D.get_domains_and_infos c [D.ListActive]),
 583       s_"List the running domains.",
 584       [];
 585     "list-all",
 586       cmd0 print_domain_list
 587         (fun () ->
 588            let c = get_readonly_connection () in
 589            D.get_domains_and_infos c [D.ListAll]),
 590       s_"List the running domains.",
 591       [];
 592     "list-defined",
 593       cmd0 print_domain_list
 594         (fun () ->
 595            let c = get_readonly_connection () in
 596            D.get_domains_and_infos c [D.ListInactive]),
 597       s_"List the defined but not running domains.",
 598       [];
 599     "quit",
 600       cmd0 no_return (fun () -> exit 0),
 601       s_"Quit the interactive terminal.",
 602       [];
 603     "maxvcpus",
 604       cmd0 print_int
 605         (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()),
 606       s_"Print the max VCPUs available.",
 607       [];
 608     "net-autostart",
 609       cmd2 no_return N.set_autostart
 610         (arg_full_connection network_of_string) boolean_of_string,
 611       s_"Set whether a network autostarts at boot.",
 612       [net_help; "on|off", s_"new autostart status of network"];
 613     "net-bridgename",
 614       cmd1 print_endline N.get_bridge_name
 615         (arg_readonly_connection network_of_string),
 616       s_"Print the bridge name of a network.",
 617       [net_help];
 618     "net-create",
 619       cmd1 no_return
 620         (fun xml -> N.create_xml (get_full_connection ()) xml) input_file,
 621       s_"Create a network from an XML file.",
 622       [s_"file",s_"XML file describing network"];
 623     "net-define",
 624       cmd1 no_return
 625         (fun xml -> N.define_xml (get_full_connection ()) xml) input_file,
 626       s_"Define (but don't start) a network from an XML file.",
 627       [s_"file",s_"XML file describing network"];
 628     "net-destroy",
 629       cmd1 no_return N.destroy (arg_full_connection network_of_string),
 630       s_"Destroy a network.",
 631       [net_help];
 632     "net-dumpxml",
 633       cmd1 print_endline N.get_xml_desc
 634         (arg_full_connection network_of_string),
 635       s_"Print the XML description of a network.",
 636       [net_help];
 637     "net-get-autostart",
 638       cmd1 print_bool N.get_autostart
 639         (arg_full_connection network_of_string),
 640       s_"Print whether a network autostarts at boot.",
 641       [net_help];
 642     "net-list",
 643       cmd0 print_network_array
 644         (fun () ->
 645            let c = get_readonly_connection () in
 646            let n = C.num_of_networks c in
 647            let nets = C.list_networks c n in
 648            Array.map (N.lookup_by_name c) nets),
 649       s_"List the active networks.",
 650       [];
 651     "net-list-defined",
 652       cmd0 print_network_array
 653         (fun () ->
 654            let c = get_readonly_connection () in
 655            let n = C.num_of_defined_networks c in
 656            let nets = C.list_defined_networks c n in
 657            Array.map (N.lookup_by_name c) nets),
 658       s_"List the defined but inactive networks.",
 659       [];
 660     "net-name",
 661       cmd1 print_endline N.get_name
 662         (arg_readonly_connection network_of_string),
 663       s_"Print the name of a network.",
 664       [net_help];
 665     "net-start",
 666       cmd1 no_return N.create
 667         (arg_full_connection network_of_string),
 668       s_"Start a previously defined inactive network.",
 669       [net_help];
 670     "net-undefine",
 671       cmd1 no_return N.undefine
 672         (arg_full_connection network_of_string),
 673       s_"Undefine an inactive network.",
 674       [net_help];
 675     "net-uuid",
 676       cmd1 print_endline N.get_uuid_string
 677         (arg_readonly_connection network_of_string),
 678       s_"Print the UUID of a network.",
 679       [net_help];
 680     "nodeinfo",
 681       cmd0 print_node_info (with_readonly_connection C.get_node_info),
 682       s_"Print node information.",
 683       [];
 684     "reboot",
 685       cmd1 no_return D.reboot (arg_full_connection domain_of_string),
 686       s_"Reboot a domain.",
 687       [dom_help];
 688     "restore",
 689       cmd1 no_return (
 690         fun path -> D.restore (get_full_connection ()) path
 691         ) string_of_string,
 692       s_"Restore a domain from the named file.",
 693       [dom_help; s_"file",s_"Domain image file"];
 694     "resume",
 695       cmd1 no_return D.resume (arg_full_connection domain_of_string),
 696       s_"Resume a domain.",
 697       [dom_help];
 698     "save",
 699       cmd2 no_return D.save
 700         (arg_full_connection domain_of_string) string_of_string,
 701       s_"Save a domain to a file.",
 702       [dom_help; s_"file",s_"Domain image file"];
 703     "schedparams",
 704       cmd1 print_sched_param_array (
 705         fun dom ->
 706           let n = snd (D.get_scheduler_type dom) in
 707           D.get_scheduler_parameters dom n
 708         ) (arg_readonly_connection domain_of_string),
 709       s_"Get the current scheduler parameters for a domain.",
 710       [dom_help];
 711     "schedparamset",
 712       cmdN no_return (
 713         function
 714         | [] -> failwith (s_"expecting domain followed by field value pairs")
 715         | dom :: pairs ->
 716             let conn = get_full_connection () in
 717             let dom = domain_of_string conn dom in
 718             let params = parse_sched_params pairs in
 719             let params = Array.of_list params in
 720             D.set_scheduler_parameters dom params
 721         ),
 722       s_"Set the scheduler parameters for a domain.",
 723       [dom_help];
 724     "schedtype",
 725       cmd1 print_endline
 726         (fun dom -> fst (D.get_scheduler_type dom))
 727         (arg_readonly_connection domain_of_string),
 728       s_"Get the scheduler type.",
 729       [dom_help];
 730     "setmem",
 731       cmd2 no_return D.set_memory
 732         (arg_full_connection domain_of_string) Int64.of_string,
 733       s_"Set the memory used by the domain (in kilobytes).",
 734       [dom_help; s_"mem",s_"memory to use (in KB)"];
 735     "setmaxmem",
 736       cmd2 no_return D.set_max_memory
 737         (arg_full_connection domain_of_string) Int64.of_string,
 738       s_"Set the maximum memory used by the domain (in kilobytes).",
 739       [dom_help; s_"mem",s_"maximum memory to use (in KB)"];
 740     "shutdown",
 741       cmd1 no_return D.shutdown
 742         (arg_full_connection domain_of_string),
 743       s_"Gracefully shutdown a domain.",
 744       [dom_help];
 745     "start",
 746       cmd1 no_return D.create
 747         (arg_full_connection domain_of_string),
 748       s_"Start a previously defined inactive domain.",
 749       [dom_help];
 750     "suspend",
 751       cmd1 no_return D.suspend
 752         (arg_full_connection domain_of_string),
 753       s_"Suspend a domain.",
 754       [dom_help];
 755     "type",
 756       cmd0 print_endline (with_readonly_connection C.get_type),
 757       s_"Print the driver name",
 758       [];
 759     "undefine",
 760       cmd1 no_return D.undefine
 761         (arg_full_connection domain_of_string),
 762       s_"Undefine an inactive domain.",
 763       [dom_help];
 764     "uri",
 765       cmd0 print_endline (with_readonly_connection C.get_uri),
 766       s_"Print the canonical URI.",
 767       [];
 768     "vcpuinfo",
 769       cmd1 print_vcpu_info (
 770         fun dom ->
 771           let c = get_readonly_connection () in
 772           let info = C.get_node_info c in
 773           let dominfo = D.get_info dom in
 774           let maxcpus = C.maxcpus_of_node_info info in
 775           let maplen = C.cpumaplen maxcpus in
 776           let maxinfo = dominfo.D.nr_virt_cpu in
 777           let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in
 778           ncpus, vcpu_infos, cpumaps, maplen, maxcpus
 779         ) (arg_readonly_connection domain_of_string),
 780       s_"Pin domain VCPU to a list of physical CPUs.",
 781       [dom_help];
 782     "vcpupin",
 783       cmd3 no_return D.pin_vcpu
 784         (arg_full_connection domain_of_string) int_of_string cpumap_of_string,
 785       s_"Pin domain VCPU to a list of physical CPUs.",
 786       [dom_help; s_"vcpu",s_"Virtual CPU number";
 787        s_"pcpus",s_"Comma-separated list of physical CPUs"];
 788     "vcpus",
 789       cmd2 no_return D.set_vcpus
 790         (arg_full_connection domain_of_string) int_of_string,
 791       s_"Set the number of virtual CPUs assigned to a domain.",
 792       [dom_help; s_"nrvcpus",s_"Number of virtual CPUs"];
 793     "version",
 794       cmd0 print_version (with_readonly_connection C.get_version),
 795       s_"Print the driver version",
 796       [];
 797   ] in
 798
 799   (* Command help. *)
 800   let help = function
 801     | None ->                           (* List of commands. *)
 802         String.concat "\n" (
 803           List.map (
 804             fun (cmd, _, description, _) ->
 805               sprintf "%-16s %s" cmd description
 806           ) commands
 807         ) ^
 808         "\n\n" ^
 809         sprintf (f_"Use '%s help command' for help on a command.")
 810           program_name
 811
 812     | Some command ->                   (* Full description of one command. *)
 813         try
 814           let command, _, description, args =
 815             List.find (fun (c, _, _, _) -> c = command) commands in
 816
 817           let arg_names = String.concat " " (List.map fst args) in
 818           let args =
 819             String.concat "" (
 820               List.map (
 821                 fun (name, help) -> sprintf "    %-12s %s\n" name help
 822               ) args) in
 823
 824           sprintf "%s %s %s\n\n%s\n\n%s"
 825             program_name command arg_names description args
 826         with
 827           Not_found ->
 828             sprintf (f_"help: %s: command not found\n") command;
 829   in
 830
 831   let commands =
 832     ("help",
 833      cmd01 print_string help string_of_string,
 834      s_"Print list of commands or full description of one command.",
 835      [s_"cmd",s_"Show help for 'mlvirsh cmd' (optional)"];
 836     ) :: commands in
 837
 838   (* Execute a command. *)
 839   let do_command command args =
 840     try
 841       let _, cmd, _, _ =
 842         List.find (fun (c, _, _, _) -> c = command) commands in
 843       cmd args
 844     with
 845       Not_found ->
 846         failwith (sprintf (f_"%s: command not found") command);
 847   in
 848
 849   do_command
 850
 851 (* Interactive mode. *)
 852 let rec interactive_mode () =
 853   let prompt =
 854     match !conn with
 855     | No_connection -> s_"mlvirsh(no connection)" ^ "$ "
 856     | RO _ -> s_"mlvirsh(ro)" ^ "$ "
 857     | RW _ -> s_"mlvirsh" ^ "# " in
 858   print_string prompt;
 859   let command = read_line () in
 860   (match str_nsplit command " " with
 861    | [] -> ()
 862    | command :: args ->
 863        do_command command args
 864   );
 865   Gc.full_major (); (* Free up all unreachable domain and network objects. *)
 866   interactive_mode ()
 867
 868 (* Connect to hypervisor.  Allow the connection to fail. *)
 869 let () =
 870   conn :=
 871     try
 872       if readonly then RO (C.connect_readonly ?name ())
 873       else RW (C.connect ?name ())
 874     with
 875       Libvirt.Virterror err ->
 876         eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err);
 877         No_connection
 878
 879 let () =
 880   try
 881     (* Execute the command on the command line, if there was one.
 882      * Otherwise go into interactive mode.
 883      *)
 884     (match extra_args with
 885      | command :: args ->
 886          do_command command args
 887      | [] ->
 888          try interactive_mode () with End_of_file -> ()
 889     );
 890
 891     (* If we are connected to a hypervisor, close the connection. *)
 892     close_connection ();
 893
 894     (* A good way to find heap bugs: *)
 895     Gc.compact ()
 896   with
 897   | Libvirt.Virterror err ->
 898       eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err)
 899   | Failure msg ->
 900       eprintf "%s: %s\n" program_name msg