X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;ds=sidebyside;f=mlvirsh%2Fmlvirsh.ml;fp=mlvirsh%2Fmlvirsh.ml;h=0000000000000000000000000000000000000000;hb=02f1c03c9f81e25353aae4900ce19e194b507f71;hp=ba4860fcdbde7ed53840a644a4a91c74af01e008;hpb=0bdb08c61ec66a16a81c2778a2a76cac77b08fda;p=virt-top.git diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml deleted file mode 100644 index ba4860f..0000000 --- a/mlvirsh/mlvirsh.ml +++ /dev/null @@ -1,770 +0,0 @@ -(* virsh-like command line tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*) - -open Printf -open Mlvirsh_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Program name. *) -let program_name = Filename.basename Sys.executable_name - -(* Parse arguments. *) -let name = ref "" -let readonly = ref false - -let argspec = Arg.align [ - "-c", Arg.Set_string name, "URI " ^ s_ "Hypervisor connection URI"; - "-r", Arg.Set readonly, " " ^ s_ "Read-only connection"; -] - -let usage_msg = - sprintf (f_ "Synopsis: - %s [options] [command] - -List of all commands: - %s help - -Full description of a single command: - %s help command - -Options:") - program_name program_name program_name - -let add_extra_arg, get_extra_args = - let extra_args = ref [] in - let add_extra_arg s = extra_args := s :: !extra_args in - let get_extra_args () = List.rev !extra_args in - add_extra_arg, get_extra_args - -let () = Arg.parse argspec add_extra_arg usage_msg - -let name = match !name with "" -> None | name -> Some name -let readonly = !readonly -let extra_args = get_extra_args () - -(* Read a whole file into memory and return it (as a string). *) -let rec input_file filename = - let chan = open_in_bin filename in - let data = input_all chan in - close_in chan; - data -and input_all chan = - let buf = Buffer.create 16384 in - let tmpsize = 16384 in - let tmp = String.create tmpsize in - let n = ref 0 in - while n := input chan tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; - done; - Buffer.contents buf - -(* Split a string at a separator. - * Functions copied from extlib Copyright (C) 2003 Nicolas Cannasse et al. - * to avoid the explicit dependency on extlib. - *) -let str_find str sub = - let sublen = String.length sub in - if sublen = 0 then - 0 - else - let found = ref 0 in - let len = String.length str in - try - for i = 0 to len - sublen do - let j = ref 0 in - while String.unsafe_get str (i + !j) = String.unsafe_get sub !j do - incr j; - if !j = sublen then begin found := i; raise Exit; end; - done; - done; - raise Not_found - with - Exit -> !found - -let str_split str sep = - let p = str_find str sep in - let len = String.length sep in - let slen = String.length str in - String.sub str 0 p, String.sub str (p + len) (slen - p - len) - -let str_nsplit str sep = - if str = "" then [] - else ( - let rec nsplit str sep = - try - let s1 , s2 = str_split str sep in - s1 :: nsplit s2 sep - with - Not_found -> [str] - in - nsplit str sep - ) - -(* Hypervisor connection. *) -type conn_t = No_connection | RO of Libvirt.ro C.t | RW of Libvirt.rw C.t -let conn = ref No_connection - -let close_connection () = - match !conn with - | No_connection -> () - | RO c -> - C.close c; - conn := No_connection - | RW c -> - C.close c; - conn := No_connection - -let do_command = - (* Command helper functions. - * - * Each cmd is a function that constructs a command. - * string string string ... <--- user types on the command line - * | | | - * arg1 arg2 arg3 ... <--- conversion functions - * | | | - * V V V - * function f <--- work function - * | - * V - * print result <--- printing function - * - * (Note that cmd function constructs and returns the above - * function, it isn't the function itself.) - * - * Example: If the function takes one parameter (an int) and - * returns a string to be printed, you would use: - * - * cmd1 print_endline f int_of_string - *) - let cmd0 print fn = function (* Command with no args. *) - | [] -> print (fn ()) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd1 print fn arg1 = function (* Command with one arg. *) - | [str1] -> print (fn (arg1 str1)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd2 print fn arg1 arg2 = function (* Command with 2 args. *) - | [str1; str2] -> print (fn (arg1 str1) (arg2 str2)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd3 print fn arg1 arg2 arg3 = function (* Command with 3 args. *) - | [str1; str2; str3] -> print (fn (arg1 str1) (arg2 str2) (arg3 str3)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd01 print fn arg1 = function (* Command with 0 or 1 arg. *) - | [] -> print (fn None) - | [str1] -> print (fn (Some (arg1 str1))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd12 print fn arg1 arg2 = function (* Command with 1 or 2 args. *) - | [str1] -> print (fn (arg1 str1) None) - | [str1; str2] -> print (fn (arg1 str1) (Some (arg2 str2))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd012 print fn arg1 arg2 = function (* Command with 0, 1 or 2 args. *) - | [] -> print (fn None None) - | [str1] -> print (fn (Some (arg1 str1)) None) - | [str1; str2] -> print (fn (Some (arg1 str1)) (Some (arg2 str2))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmdN print fn = (* Command with any number of args. *) - fun args -> print (fn args) - in - - (* Get the connection or fail if we don't have one. *) - let rec get_full_connection () = - match !conn with - | No_connection -> failwith (s_ "not connected to the hypervisor") - | RO _ -> failwith (s_ "tried to do read-write operation on read-only hypervisor connection") - | RW conn -> conn - and get_readonly_connection () = - match !conn with - | No_connection -> failwith (s_ "not connected to the hypervisor") - | RO conn -> conn - | RW conn -> C.const conn -(* - and with_full_connection fn = - fun () -> fn (get_full_connection ()) -*) - and with_readonly_connection fn = - fun () -> fn (get_readonly_connection ()) - and arg_full_connection fn = - fun str -> fn (get_full_connection ()) str - and arg_readonly_connection fn = - fun str -> fn (get_readonly_connection ()) str - in - - (* Parsing of command arguments. *) - let string_of_readonly = function - | "readonly" | "read-only" | "ro" -> true - | _ -> failwith (sprintf (f_ "flag should be '%s'") "readonly") - in - let string_of_string (str : string) = str in - let boolean_of_string = function - | "enable" | "enabled" | "on" | "1" | "true" -> true - | "disable" | "disabled" | "off" | "0" | "false" -> false - | _ -> failwith (sprintf (f_ "setting should be '%s' or '%s'") "on" "off") - in - let domain_of_string conn str = - try - (try - let id = int_of_string str in - D.lookup_by_id conn id - with - Failure "int_of_string" -> - if String.length str = Libvirt.uuid_string_length then - D.lookup_by_uuid_string conn str - else - D.lookup_by_name conn str - ) - with - Libvirt.Virterror err -> - failwith (sprintf (f_ "domain %s: not found. Additional info: %s") - str (Libvirt.Virterror.to_string err)); - in - let network_of_string conn str = - try - if String.length str = Libvirt.uuid_string_length then - N.lookup_by_uuid_string conn str - else - N.lookup_by_name conn str - with - Libvirt.Virterror err -> - failwith (sprintf (f_ "network %s: not found. Additional info: %s") - str (Libvirt.Virterror.to_string err)); - in - let rec parse_sched_params = function - | [] -> [] - | [_] -> failwith (s_ "expected field value pairs, but got an odd number of arguments") - | field :: value :: rest -> - (* XXX We only support the UINT type at the moment. *) - (field, D.SchedFieldUInt32 (Int32.of_string value)) - :: parse_sched_params rest - in - let cpumap_of_string str = - let c = get_readonly_connection () in - let info = C.get_node_info c in - let cpumap = - String.make (C.cpumaplen (C.maxcpus_of_node_info info)) '\000' in - List.iter (C.use_cpu cpumap) - (List.map int_of_string (str_nsplit str ",")); - cpumap - in - - (* Printing of command results. *) - let no_return _ = () in - let print_int i = print_endline (string_of_int i) in - let print_int64 i = print_endline (Int64.to_string i) in - let print_int64_array a = Array.iter print_int64 a in - let print_bool b = print_endline (string_of_bool b) in - let print_version v = - let major = v / 1000000 in - let minor = (v - major * 1000000) / 1000 in - let release = (v - major * 1000000 - minor * 1000) in - printf "%d.%d.%d\n" major minor release - in - let string_of_domain_state = function - | D.InfoNoState -> s_ "unknown" - | D.InfoRunning -> s_ "running" - | D.InfoBlocked -> s_ "blocked" - | D.InfoPaused -> s_ "paused" - | D.InfoShutdown -> s_ "shutdown" - | D.InfoShutoff -> s_ "shutoff" - | D.InfoCrashed -> s_ "crashed" - in - let string_of_vcpu_state = function - | D.VcpuOffline -> s_ "offline" - | D.VcpuRunning -> s_ "running" - | D.VcpuBlocked -> s_ "blocked" - in - let print_domain_array doms = - Array.iter ( - fun dom -> - let id = - try sprintf "%d" (D.get_id dom) - with Libvirt.Virterror _ -> "" in - let name = - try sprintf "%s" (D.get_name dom) - with Libvirt.Virterror _ -> "" in - let state = - try - let { D.state = state } = D.get_info dom in - string_of_domain_state state - with Libvirt.Virterror _ -> "" in - printf "%5s %-30s %s\n" id name state - ) doms - in - let print_network_array nets = - Array.iter ( - fun net -> - printf "%s\n" (N.get_name net) - ) nets - in - let print_node_info info = - let () = printf (f_ "model: %s\n") info.C.model in - let () = printf (f_ "memory: %Ld K\n") info.C.memory in - let () = printf (f_ "cpus: %d\n") info.C.cpus in - let () = printf (f_ "mhz: %d\n") info.C.mhz in - let () = printf (f_ "nodes: %d\n") info.C.nodes in - let () = printf (f_ "sockets: %d\n") info.C.sockets in - let () = printf (f_ "cores: %d\n") info.C.cores in - let () = printf (f_ "threads: %d\n") info.C.threads in - () - in - let print_domain_state { D.state = state } = - print_endline (string_of_domain_state state) - in - let print_domain_info info = - let () = printf (f_ "state: %s\n") (string_of_domain_state info.D.state) in - let () = printf (f_ "max_mem: %Ld K\n") info.D.max_mem in - let () = printf (f_ "memory: %Ld K\n") info.D.memory in - let () = printf (f_ "nr_virt_cpu: %d\n") info.D.nr_virt_cpu in - let () = printf (f_ "cpu_time: %Ld ns\n") info.D.cpu_time in - () - in - let print_sched_param_array params = - Array.iter ( - fun (name, value) -> - printf "%-20s" name; - match value with - | D.SchedFieldInt32 i -> printf " %ld\n" i - | D.SchedFieldUInt32 i -> printf " %lu\n" i - | D.SchedFieldInt64 i -> printf " %Ld\n" i - | D.SchedFieldUInt64 i -> printf " %Lu\n" i - | D.SchedFieldFloat f -> printf " %g\n" f - | D.SchedFieldBool b -> printf " %b\n" b - ) params - in - let print_vcpu_info (ncpus, vcpu_infos, cpumaps, maplen, maxcpus) = - for n = 0 to ncpus-1 do - let () = printf (f_ "virtual CPU: %d\n") n in - let () = printf (f_ "\ton physical CPU: %d\n") vcpu_infos.(n).D.cpu in - let () = printf (f_ "\tcurrent state: %s\n") - (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state) in - let () = printf (f_ "\tCPU time: %Ld ns\n") vcpu_infos.(n).D.vcpu_time in - print_string ("\t" ^ s_ "CPU affinity" ^ ": "); - for m = 0 to maxcpus-1 do - print_char (if C.cpu_usable cpumaps maplen n m then 'y' else '-') - done; - print_endline ""; - done - in - let print_block_stats { D.rd_req = rd_req; rd_bytes = rd_bytes; - wr_req = wr_req; wr_bytes = wr_bytes; - errs = errs } = - if rd_req >= 0L then printf (f_ "read requests: %Ld\n") rd_req; - if rd_bytes >= 0L then printf (f_ "read bytes: %Ld\n") rd_bytes; - if wr_req >= 0L then printf (f_ "write requests: %Ld\n") wr_req; - if wr_bytes >= 0L then printf (f_ "write bytes: %Ld\n") wr_bytes; - if errs >= 0L then printf (f_ "errors: %Ld\n") errs; - and print_interface_stats { D.rx_bytes = rx_bytes; rx_packets = rx_packets; - rx_errs = rx_errs; rx_drop = rx_drop; - tx_bytes = tx_bytes; tx_packets = tx_packets; - tx_errs = tx_errs; tx_drop = tx_drop } = - if rx_bytes >= 0L then printf (f_ "rx bytes: %Ld\n") rx_bytes; - if rx_packets >= 0L then printf (f_ "rx packets: %Ld\n") rx_packets; - if rx_errs >= 0L then printf (f_ "rx errs: %Ld\n") rx_errs; - if rx_drop >= 0L then printf (f_ "rx dropped: %Ld\n") rx_drop; - if tx_bytes >= 0L then printf (f_ "tx bytes: %Ld\n") tx_bytes; - if tx_packets >= 0L then printf (f_ "tx packets: %Ld\n") tx_packets; - if tx_errs >= 0L then printf (f_ "tx errs: %Ld\n") tx_errs; - if tx_drop >= 0L then printf (f_ "tx dropped: %Ld\n") tx_drop; - in - - (* List of commands. *) - let commands = [ - "attach-device", - cmd2 no_return D.attach_device - (arg_full_connection domain_of_string) input_file, - s_ "Attach device to domain."; - "autostart", - cmd2 no_return D.set_autostart - (arg_full_connection domain_of_string) boolean_of_string, - s_ "Set whether a domain autostarts at boot."; - "capabilities", - cmd0 print_endline (with_readonly_connection C.get_capabilities), - s_ "Returns capabilities of hypervisor/driver."; - "close", - cmd0 no_return close_connection, - s_ "Close an existing hypervisor connection."; - "connect", - cmd12 no_return - (fun name readonly -> - close_connection (); - match readonly with - | None | Some false -> conn := RW (C.connect ~name ()) - | Some true -> conn := RO (C.connect_readonly ~name ()) - ) string_of_string string_of_readonly, - s_ "Open a new hypervisor connection."; - "create", - cmd1 no_return - (fun xml -> D.create_linux (get_full_connection ()) xml) input_file, - s_ "Create a domain from an XML file."; - "define", - cmd1 no_return - (fun xml -> D.define_xml (get_full_connection ()) xml) input_file, - s_ "Define (but don't start) a domain from an XML file."; - "detach-device", - cmd2 no_return D.detach_device - (arg_full_connection domain_of_string) input_file, - s_ "Detach device from domain."; - "destroy", - cmd1 no_return D.destroy (arg_full_connection domain_of_string), - s_ "Destroy a domain."; - "domblkstat", - cmd2 print_block_stats D.block_stats - (arg_readonly_connection domain_of_string) string_of_string, - s_ "Display the block device statistics for a domain."; - "domid", - cmd1 print_int D.get_id (arg_readonly_connection domain_of_string), - s_ "Print the ID of a domain."; - "domifstat", - cmd2 print_interface_stats D.interface_stats - (arg_readonly_connection domain_of_string) string_of_string, - s_ "Display the network interface statistics for a domain."; - "dominfo", - cmd1 print_domain_info D.get_info - (arg_readonly_connection domain_of_string), - s_ "Print the domain info."; - "dommaxmem", - cmd1 print_int64 D.get_max_memory - (arg_readonly_connection domain_of_string), - s_ "Print the max memory (in kilobytes) of a domain."; - "dommaxvcpus", - cmd1 print_int D.get_max_vcpus - (arg_readonly_connection domain_of_string), - s_ "Print the max VCPUs of a domain."; - "domname", - cmd1 print_endline D.get_name - (arg_readonly_connection domain_of_string), - s_ "Print the name of a domain."; - "domostype", - cmd1 print_endline D.get_os_type - (arg_readonly_connection domain_of_string), - s_ "Print the OS type of a domain."; - "domstate", - cmd1 print_domain_state D.get_info - (arg_readonly_connection domain_of_string), - s_ "Print the domain state."; - "domuuid", - cmd1 print_endline D.get_uuid_string - (arg_readonly_connection domain_of_string), - s_ "Print the UUID of a domain."; - "dump", - cmd2 no_return D.core_dump - (arg_full_connection domain_of_string) string_of_string, - s_ "Core dump a domain to a file for analysis."; - "dumpxml", - cmd1 print_endline D.get_xml_desc - (arg_full_connection domain_of_string), - s_ "Print the XML description of a domain."; - "freecell", - cmd012 print_int64_array ( - fun start max -> - let conn = get_readonly_connection () in - match start, max with - | None, _ -> - [| C.node_get_free_memory conn |] - | Some start, None -> - C.node_get_cells_free_memory conn start 1 - | Some start, Some max -> - C.node_get_cells_free_memory conn start max - ) int_of_string int_of_string, - s_ "Display free memory for machine, NUMA cell or range of cells"; - "get-autostart", - cmd1 print_bool D.get_autostart - (arg_readonly_connection domain_of_string), - s_ "Print whether a domain autostarts at boot."; - "hostname", - cmd0 print_endline (with_readonly_connection C.get_hostname), - s_ "Print the hostname."; - "list", - cmd0 print_domain_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_domains c in - let domids = C.list_domains c n in - Array.map (D.lookup_by_id c) domids), - s_ "List the running domains."; - "list-defined", - cmd0 print_domain_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_defined_domains c in - let domnames = C.list_defined_domains c n in - Array.map (D.lookup_by_name c) domnames), - s_ "List the defined but not running domains."; - "quit", - cmd0 no_return (fun () -> exit 0), - s_ "Quit the interactive terminal."; - "maxvcpus", - cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()), - s_ "Print the max VCPUs available."; - "net-autostart", - cmd2 no_return N.set_autostart - (arg_full_connection network_of_string) boolean_of_string, - s_ "Set whether a network autostarts at boot."; - "net-bridgename", - cmd1 print_endline N.get_bridge_name - (arg_readonly_connection network_of_string), - s_ "Print the bridge name of a network."; - "net-create", - cmd1 no_return - (fun xml -> N.create_xml (get_full_connection ()) xml) input_file, - s_ "Create a network from an XML file."; - "net-define", - cmd1 no_return - (fun xml -> N.define_xml (get_full_connection ()) xml) input_file, - s_ "Define (but don't start) a network from an XML file."; - "net-destroy", - cmd1 no_return N.destroy (arg_full_connection network_of_string), - s_ "Destroy a network."; - "net-dumpxml", - cmd1 print_endline N.get_xml_desc - (arg_full_connection network_of_string), - s_ "Print the XML description of a network."; - "net-get-autostart", - cmd1 print_bool N.get_autostart - (arg_full_connection network_of_string), - s_ "Print whether a network autostarts at boot."; - "net-list", - cmd0 print_network_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_networks c in - let nets = C.list_networks c n in - Array.map (N.lookup_by_name c) nets), - s_ "List the active networks."; - "net-list-defined", - cmd0 print_network_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_defined_networks c in - let nets = C.list_defined_networks c n in - Array.map (N.lookup_by_name c) nets), - s_ "List the defined but inactive networks."; - "net-name", - cmd1 print_endline N.get_name - (arg_readonly_connection network_of_string), - s_ "Print the name of a network."; - "net-start", - cmd1 no_return N.create - (arg_full_connection network_of_string), - s_ "Start a previously defined inactive network."; - "net-undefine", - cmd1 no_return N.undefine - (arg_full_connection network_of_string), - s_ "Undefine an inactive network."; - "net-uuid", - cmd1 print_endline N.get_uuid_string - (arg_readonly_connection network_of_string), - s_ "Print the UUID of a network."; - "nodeinfo", - cmd0 print_node_info (with_readonly_connection C.get_node_info), - s_ "Print node information."; - "reboot", - cmd1 no_return D.reboot (arg_full_connection domain_of_string), - s_ "Reboot a domain."; - "restore", - cmd1 no_return ( - fun path -> D.restore (get_full_connection ()) path - ) string_of_string, - s_ "Restore a domain from the named file."; - "resume", - cmd1 no_return D.resume (arg_full_connection domain_of_string), - s_ "Resume a domain."; - "save", - cmd2 no_return D.save - (arg_full_connection domain_of_string) string_of_string, - s_ "Save a domain to a file."; - "schedparams", - cmd1 print_sched_param_array ( - fun dom -> - let n = snd (D.get_scheduler_type dom) in - D.get_scheduler_parameters dom n - ) (arg_readonly_connection domain_of_string), - s_ "Get the current scheduler parameters for a domain."; - "schedparamset", - cmdN no_return ( - function - | [] -> failwith (s_ "expecting domain followed by field value pairs") - | dom :: pairs -> - let conn = get_full_connection () in - let dom = domain_of_string conn dom in - let params = parse_sched_params pairs in - let params = Array.of_list params in - D.set_scheduler_parameters dom params - ), - s_ "Set the scheduler parameters for a domain."; - "schedtype", - cmd1 print_endline - (fun dom -> fst (D.get_scheduler_type dom)) - (arg_readonly_connection domain_of_string), - s_ "Get the scheduler type."; - "setmem", - cmd2 no_return D.set_memory - (arg_full_connection domain_of_string) Int64.of_string, - s_ "Set the memory used by the domain (in kilobytes)."; - "setmaxmem", - cmd2 no_return D.set_max_memory - (arg_full_connection domain_of_string) Int64.of_string, - s_ "Set the maximum memory used by the domain (in kilobytes)."; - "shutdown", - cmd1 no_return D.shutdown - (arg_full_connection domain_of_string), - s_ "Gracefully shutdown a domain."; - "start", - cmd1 no_return D.create - (arg_full_connection domain_of_string), - s_ "Start a previously defined inactive domain."; - "suspend", - cmd1 no_return D.suspend - (arg_full_connection domain_of_string), - s_ "Suspend a domain."; - "type", - cmd0 print_endline (with_readonly_connection C.get_type), - s_ "Print the driver name"; - "undefine", - cmd1 no_return D.undefine - (arg_full_connection domain_of_string), - s_ "Undefine an inactive domain."; - "uri", - cmd0 print_endline (with_readonly_connection C.get_uri), - s_ "Print the canonical URI."; - "vcpuinfo", - cmd1 print_vcpu_info ( - fun dom -> - let c = get_readonly_connection () in - let info = C.get_node_info c in - let dominfo = D.get_info dom in - let maxcpus = C.maxcpus_of_node_info info in - let maplen = C.cpumaplen maxcpus in - let maxinfo = dominfo.D.nr_virt_cpu in - let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in - ncpus, vcpu_infos, cpumaps, maplen, maxcpus - ) (arg_readonly_connection domain_of_string), - s_ "Pin domain VCPU to a list of physical CPUs."; - "vcpupin", - cmd3 no_return D.pin_vcpu - (arg_full_connection domain_of_string) int_of_string cpumap_of_string, - s_ "Pin domain VCPU to a list of physical CPUs."; - "vcpus", - cmd2 no_return D.set_vcpus - (arg_full_connection domain_of_string) int_of_string, - s_ "Set the number of virtual CPUs assigned to a domain."; - "version", - cmd0 print_version (with_readonly_connection C.get_version), - s_ "Print the driver version"; - ] in - - (* Command help. *) - let help = function - | None -> (* List of commands. *) - String.concat "\n" ( - List.map ( - fun (cmd, _, description) -> - sprintf "%-12s %s" cmd description - ) commands - ) ^ - "\n\n" ^ - (sprintf (f_ "Use '%s help command' for help on a command.") - program_name) - - | Some command -> (* Full description of one command. *) - try - let (command, _, description) = - List.find (fun (c, _, _) -> c = command) commands in - sprintf "%s %s\n\n%s" program_name command description - with - Not_found -> - failwith (sprintf (f_ "help: %s: command not found") command); - in - - let commands = - ("help", - cmd01 print_endline help string_of_string, - s_ "Print list of commands or full description of one command."; - ) :: commands in - - (* Execute a command. *) - let do_command command args = - try - let (_, cmd, _) = List.find (fun (c, _, _) -> c = command) commands in - cmd args - with - Not_found -> - failwith (sprintf (f_ "%s: command not found") command); - in - - do_command - -(* Interactive mode. *) -let rec interactive_mode () = - let prompt = - match !conn with - | No_connection -> s_ "mlvirsh(no connection)" ^ "$ " - | RO _ -> s_ "mlvirsh(ro)" ^ "$ " - | RW _ -> s_ "mlvirsh" ^ "# " in - print_string prompt; - let command = read_line () in - (match str_nsplit command " " with - | [] -> () - | command :: args -> - do_command command args - ); - Gc.full_major (); (* Free up all unreachable domain and network objects. *) - interactive_mode () - -(* Connect to hypervisor. Allow the connection to fail. *) -let () = - conn := - try - if readonly then RO (C.connect_readonly ?name ()) - else RW (C.connect ?name ()) - with - Libvirt.Virterror err -> - eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err); - No_connection - -let () = - try - (* Execute the command on the command line, if there was one. - * Otherwise go into interactive mode. - *) - (match extra_args with - | command :: args -> - do_command command args - | [] -> - try interactive_mode () with End_of_file -> () - ); - - (* If we are connected to a hypervisor, close the connection. *) - close_connection (); - - (* A good way to find heap bugs: *) - Gc.compact () - with - | Libvirt.Virterror err -> - eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err) - | Failure msg -> - eprintf "%s: %s\n" program_name msg