diff options
author | rjones@localhost <rjones@localhost> | 2007-08-30 17:38:09 +0100 |
---|---|---|
committer | rjones@localhost <rjones@localhost> | 2007-08-30 17:38:09 +0100 |
commit | a8b837d5018c488a130fcbea425904817a862210 (patch) | |
tree | 44fc8f4a58d6e1651053c4c40d32b3816add43fa /mlvirsh | |
download | virt-top-a8b837d5018c488a130fcbea425904817a862210.tar.gz virt-top-a8b837d5018c488a130fcbea425904817a862210.tar.xz virt-top-a8b837d5018c488a130fcbea425904817a862210.zip |
Initial import from CVS.
Diffstat (limited to 'mlvirsh')
-rw-r--r-- | mlvirsh/.cvsignore | 8 | ||||
-rw-r--r-- | mlvirsh/.depend | 2 | ||||
-rw-r--r-- | mlvirsh/Makefile | 42 | ||||
-rw-r--r-- | mlvirsh/Makefile.in | 42 | ||||
-rw-r--r-- | mlvirsh/mlvirsh.ml | 690 |
5 files changed, 784 insertions, 0 deletions
diff --git a/mlvirsh/.cvsignore b/mlvirsh/.cvsignore new file mode 100644 index 0000000..7d561e2 --- /dev/null +++ b/mlvirsh/.cvsignore @@ -0,0 +1,8 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa +Makefile +mlvirsh +mlvirsh.opt
\ No newline at end of file diff --git a/mlvirsh/.depend b/mlvirsh/.depend new file mode 100644 index 0000000..a346edd --- /dev/null +++ b/mlvirsh/.depend @@ -0,0 +1,2 @@ +mlvirsh.cmo: ../libvirt/libvirt.cmi +mlvirsh.cmx: ../libvirt/libvirt.cmx diff --git a/mlvirsh/Makefile b/mlvirsh/Makefile new file mode 100644 index 0000000..5160fde --- /dev/null +++ b/mlvirsh/Makefile @@ -0,0 +1,42 @@ +# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $ + +INSTALL := /usr/bin/install -c + +prefix = /usr/local +exec_prefix = ${prefix} +bindir = ${exec_prefix}/bin + +OCAMLCPACKAGES := -package extlib,unix -I ../libvirt +OCAMLCFLAGS := -g +OCAMLCLIBS := -linkpkg + +OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) +OCAMLOPTFLAGS := +OCAMLOPTLIBS := $(OCAMLCLIBS) + +export LIBRARY_PATH=../libvirt +export LD_LIBRARY_PATH=../libvirt + +BYTE_TARGETS := mlvirsh +OPT_TARGETS := mlvirsh.opt + +all: $(BYTE_TARGETS) + +opt: $(OPT_TARGETS) + +mlvirsh: mlvirsh.cmo + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + ../libvirt/mllibvirt.cma -o $@ $< + +mlvirsh.opt: mlvirsh.cmx + ocamlfind ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + ../libvirt/mllibvirt.cmxa -o $@ $< + +install: + if [ -x mlvirsh.opt ]; then \ + mkdir -p $(DESTDIR)$(bindir); \ + $(INSTALL) -m 0755 mlvirsh.opt $(DESTDIR)$(bindir)/mlvirsh; \ + fi + +include ../Make.rules diff --git a/mlvirsh/Makefile.in b/mlvirsh/Makefile.in new file mode 100644 index 0000000..3798962 --- /dev/null +++ b/mlvirsh/Makefile.in @@ -0,0 +1,42 @@ +# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $ + +INSTALL := @INSTALL@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ + +OCAMLCPACKAGES := -package extlib,unix -I ../libvirt +OCAMLCFLAGS := -g +OCAMLCLIBS := -linkpkg + +OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) +OCAMLOPTFLAGS := +OCAMLOPTLIBS := $(OCAMLCLIBS) + +export LIBRARY_PATH=../libvirt +export LD_LIBRARY_PATH=../libvirt + +BYTE_TARGETS := mlvirsh +OPT_TARGETS := mlvirsh.opt + +all: $(BYTE_TARGETS) + +opt: $(OPT_TARGETS) + +mlvirsh: mlvirsh.cmo + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + ../libvirt/mllibvirt.cma -o $@ $< + +mlvirsh.opt: mlvirsh.cmx + ocamlfind ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + ../libvirt/mllibvirt.cmxa -o $@ $< + +install: + if [ -x mlvirsh.opt ]; then \ + mkdir -p $(DESTDIR)$(bindir); \ + $(INSTALL) -m 0755 mlvirsh.opt $(DESTDIR)$(bindir)/mlvirsh; \ + fi + +include ../Make.rules diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml new file mode 100644 index 0000000..5b63a77 --- /dev/null +++ b/mlvirsh/mlvirsh.ml @@ -0,0 +1,690 @@ +(* virsh-like command line tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirsh.ml,v 1.2 2007/08/21 13:24:09 rjones Exp $ +*) + +open ExtString +open Printf + +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 Hypervisor connection URI"; + "-r", Arg.Set readonly, " Read-only connection"; +] + +let usage_msg = "\ +Synopsis: + " ^ program_name ^ " [options] [command] + +List of all commands: + " ^ program_name ^ " help + +Full description of a single command: + " ^ program_name ^ " help command + +Options:" + +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 + +(* 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<n> 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<n> 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 "incorrect number of arguments for function" + in + let cmd1 print fn arg1 = function (* Command with one arg. *) + | [str1] -> print (fn (arg1 str1)) + | _ -> failwith "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 "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 "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 "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 "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 "not connected to the hypervisor" + | RO _ -> failwith "tried to do read-write operation on read-only hypervisor connection" + | RW conn -> conn + and get_readonly_connection () = + match !conn with + | No_connection -> failwith "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 "flag should be '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 "setting should be 'on' or '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 ("domain " ^ str ^ ": not found. Additional info: " ^ + 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 ("network " ^ str ^ ": not found. Additional info: " ^ + Libvirt.Virterror.to_string err); + in + let rec parse_sched_params = function + | [] -> [] + | [_] -> failwith "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 (String.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_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 -> "unknown" + | D.InfoRunning -> "running" + | D.InfoBlocked -> "blocked" + | D.InfoPaused -> "paused" + | D.InfoShutdown -> "shutdown" + | D.InfoShutoff -> "shutoff" + | D.InfoCrashed -> "crashed" + in + let string_of_vcpu_state = function + | D.VcpuOffline -> "offline" + | D.VcpuRunning -> "running" + | D.VcpuBlocked -> "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 = + printf "model: %s\n" info.C.model; + printf "memory: %Ld K\n" info.C.memory; + printf "cpus: %d\n" info.C.cpus; + printf "mhz: %d\n" info.C.mhz; + printf "nodes: %d\n" info.C.nodes; + printf "sockets: %d\n" info.C.sockets; + printf "cores: %d\n" info.C.cores; + printf "threads: %d\n" info.C.threads; + in + let print_domain_state { D.state = state } = + print_endline (string_of_domain_state state) + in + let print_domain_info info = + printf "state: %s\n" (string_of_domain_state info.D.state); + printf "max_mem: %Ld K\n" info.D.max_mem; + printf "memory: %Ld K\n" info.D.memory; + printf "nr_virt_cpu: %d\n" info.D.nr_virt_cpu; + printf "cpu_time: %Ld ns\n" info.D.cpu_time; + 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 + printf "virtual CPU: %d\n" n; + printf " on physical CPU: %d\n" vcpu_infos.(n).D.cpu; + printf " current state: %s\n" + (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state); + printf " CPU time: %Ld ns\n" vcpu_infos.(n).D.vcpu_time; + printf " 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 "read requests: %Ld\n" rd_req; + if rd_bytes >= 0L then printf "read bytes: %Ld\n" rd_bytes; + if wr_req >= 0L then printf "write requests: %Ld\n" wr_req; + if wr_bytes >= 0L then printf "write bytes: %Ld\n" wr_bytes; + if errs >= 0L then printf "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 "rx bytes: %Ld\n" rx_bytes; + if rx_packets >= 0L then printf "rx packets: %Ld\n" rx_packets; + if rx_errs >= 0L then printf "rx errs: %Ld\n" rx_errs; + if rx_drop >= 0L then printf "rx dropped: %Ld\n" rx_drop; + if tx_bytes >= 0L then printf "tx bytes: %Ld\n" tx_bytes; + if tx_packets >= 0L then printf "tx packets: %Ld\n" tx_packets; + if tx_errs >= 0L then printf "tx errs: %Ld\n" tx_errs; + if tx_drop >= 0L then printf "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, + "Attach device to domain."; + "autostart", + cmd2 no_return D.set_autostart + (arg_full_connection domain_of_string) boolean_of_string, + "Set whether a domain autostarts at boot."; + "capabilities", + cmd0 print_endline (with_readonly_connection C.get_capabilities), + "Returns capabilities of hypervisor/driver."; + "close", + cmd0 no_return close_connection, + "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, + "Open a new hypervisor connection."; + "create", + cmd1 no_return + (fun xml -> D.create_linux (get_full_connection ()) xml) input_file, + "Create a domain from an XML file."; + "define", + cmd1 no_return + (fun xml -> D.define_xml (get_full_connection ()) xml) input_file, + "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, + "Detach device from domain."; + "destroy", + cmd1 no_return D.destroy (arg_full_connection domain_of_string), + "Destroy a domain."; + "domblkstat", + cmd2 print_block_stats D.block_stats + (arg_readonly_connection domain_of_string) string_of_string, + "Display the block device statistics for a domain."; + "domid", + cmd1 print_int D.get_id (arg_readonly_connection domain_of_string), + "Print the ID of a domain."; + "domifstat", + cmd2 print_interface_stats D.interface_stats + (arg_readonly_connection domain_of_string) string_of_string, + "Display the network interface statistics for a domain."; + "dominfo", + cmd1 print_domain_info D.get_info + (arg_readonly_connection domain_of_string), + "Print the domain info."; + "dommaxmem", + cmd1 print_int64 D.get_max_memory + (arg_readonly_connection domain_of_string), + "Print the max memory (in kilobytes) of a domain."; + "dommaxvcpus", + cmd1 print_int D.get_max_vcpus + (arg_readonly_connection domain_of_string), + "Print the max VCPUs of a domain."; + "domname", + cmd1 print_endline D.get_name + (arg_readonly_connection domain_of_string), + "Print the name of a domain."; + "domostype", + cmd1 print_endline D.get_os_type + (arg_readonly_connection domain_of_string), + "Print the OS type of a domain."; + "domstate", + cmd1 print_domain_state D.get_info + (arg_readonly_connection domain_of_string), + "Print the domain state."; + "domuuid", + cmd1 print_endline D.get_uuid_string + (arg_readonly_connection domain_of_string), + "Print the UUID of a domain."; + "dump", + cmd2 no_return D.core_dump + (arg_full_connection domain_of_string) string_of_string, + "Core dump a domain to a file for analysis."; + "dumpxml", + cmd1 print_endline D.get_xml_desc + (arg_full_connection domain_of_string), + "Print the XML description of a domain."; + "get-autostart", + cmd1 print_bool D.get_autostart + (arg_readonly_connection domain_of_string), + "Print whether a domain autostarts at boot."; + "hostname", + cmd0 print_endline (with_readonly_connection C.get_hostname), + "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), + "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), + "List the defined but not running domains."; + "quit", + cmd0 no_return (fun () -> exit 0), + "Quit the interactive terminal."; + "maxvcpus", + cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()), + "Print the max VCPUs available."; + "net-autostart", + cmd2 no_return N.set_autostart + (arg_full_connection network_of_string) boolean_of_string, + "Set whether a network autostarts at boot."; + "net-bridgename", + cmd1 print_endline N.get_bridge_name + (arg_readonly_connection network_of_string), + "Print the bridge name of a network."; + "net-create", + cmd1 no_return + (fun xml -> N.create_xml (get_full_connection ()) xml) input_file, + "Create a network from an XML file."; + "net-define", + cmd1 no_return + (fun xml -> N.define_xml (get_full_connection ()) xml) input_file, + "Define (but don't start) a network from an XML file."; + "net-destroy", + cmd1 no_return N.destroy (arg_full_connection network_of_string), + "Destroy a network."; + "net-dumpxml", + cmd1 print_endline N.get_xml_desc + (arg_full_connection network_of_string), + "Print the XML description of a network."; + "net-get-autostart", + cmd1 print_bool N.get_autostart + (arg_full_connection network_of_string), + "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), + "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), + "List the defined but inactive networks."; + "net-name", + cmd1 print_endline N.get_name + (arg_readonly_connection network_of_string), + "Print the name of a network."; + "net-start", + cmd1 no_return N.create + (arg_full_connection network_of_string), + "Start a previously defined inactive network."; + "net-undefine", + cmd1 no_return N.undefine + (arg_full_connection network_of_string), + "Undefine an inactive network."; + "net-uuid", + cmd1 print_endline N.get_uuid_string + (arg_readonly_connection network_of_string), + "Print the UUID of a network."; + "nodeinfo", + cmd0 print_node_info (with_readonly_connection C.get_node_info), + "Print node information."; + "reboot", + cmd1 no_return D.reboot (arg_full_connection domain_of_string), + "Reboot a domain."; + "restore", + cmd1 no_return ( + fun path -> D.restore (get_full_connection ()) path + ) string_of_string, + "Restore a domain from the named file."; + "resume", + cmd1 no_return D.resume (arg_full_connection domain_of_string), + "Resume a domain."; + "save", + cmd2 no_return D.save + (arg_full_connection domain_of_string) string_of_string, + "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), + "Get the current scheduler parameters for a domain."; + "schedparamset", + cmdN no_return ( + function + | [] -> failwith "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 + ), + "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), + "Get the scheduler type."; + "setmem", + cmd2 no_return D.set_memory + (arg_full_connection domain_of_string) Int64.of_string, + "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, + "Set the maximum memory used by the domain (in kilobytes)."; + "shutdown", + cmd1 no_return D.shutdown + (arg_full_connection domain_of_string), + "Gracefully shutdown a domain."; + "start", + cmd1 no_return D.create + (arg_full_connection domain_of_string), + "Start a previously defined inactive domain."; + "suspend", + cmd1 no_return D.suspend + (arg_full_connection domain_of_string), + "Suspend a domain."; + "type", + cmd0 print_endline (with_readonly_connection C.get_type), + "Print the driver name"; + "undefine", + cmd1 no_return D.undefine + (arg_full_connection domain_of_string), + "Undefine an inactive domain."; + "uri", + cmd0 print_endline (with_readonly_connection C.get_uri), + "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), + "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, + "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, + "Set the number of virtual CPUs assigned to a domain."; + "version", + cmd0 print_version (with_readonly_connection C.get_version), + "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\nUse '" ^ program_name ^ " help command' for help on a command." + + | 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 ("help: " ^ command ^ ": command not found"); + in + + let commands = + ("help", + cmd01 print_endline help string_of_string, + "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 (command ^ ": command not found"); + in + + do_command + +(* Interactive mode. *) +let rec interactive_mode () = + let prompt = + match !conn with + | No_connection -> "mlvirsh(no connection)$ " + | RO _ -> "mlvirsh(ro)$ " + | RW _ -> "mlvirsh# " in + print_string prompt; + let command = read_line () in + (match String.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 |