Signed-off-by: David Scott <dave.scott@xxxxxxxxxxxxx> --- .gitignore | 1 + Makefile.in | 1 + examples/.depend | 14 +++-- examples/Makefile.in | 13 ++++- examples/domain_events.ml | 145 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 167 insertions(+), 7 deletions(-) create mode 100644 examples/domain_events.ml diff --git a/.gitignore b/.gitignore index 2b5e4fd..71a245e 100644 --- a/.gitignore +++ b/.gitignore @@ -26,6 +26,7 @@ core.* *.exe *~ libvirt/libvirt_version.ml +examples/domain_events examples/get_cpu_stats examples/list_domains examples/node_info diff --git a/Makefile.in b/Makefile.in index c0622cc..3b8b7ec 100644 --- a/Makefile.in +++ b/Makefile.in @@ -40,6 +40,7 @@ clean: rm -f examples/list_domains rm -f examples/node_info rm -f examples/get_cpu_stats + rm -f examples/domain_events distclean: clean rm -f config.h config.log config.status configure diff --git a/examples/.depend b/examples/.depend index 3d955f9..8e4f133 100644 --- a/examples/.depend +++ b/examples/.depend @@ -1,6 +1,8 @@ -node_info.cmo : ../libvirt/libvirt.cmi -node_info.cmx : ../libvirt/libvirt.cmx -get_cpu_stats.cmo : ../libvirt/libvirt.cmi -get_cpu_stats.cmx : ../libvirt/libvirt.cmx -list_domains.cmo : ../libvirt/libvirt.cmi -list_domains.cmx : ../libvirt/libvirt.cmx +domain_events.cmo: ../libvirt/libvirt.cmi +domain_events.cmx: ../libvirt/libvirt.cmx +get_cpu_stats.cmo: ../libvirt/libvirt.cmi +get_cpu_stats.cmx: ../libvirt/libvirt.cmx +list_domains.cmo: ../libvirt/libvirt.cmi +list_domains.cmx: ../libvirt/libvirt.cmx +node_info.cmo: ../libvirt/libvirt.cmi +node_info.cmx: ../libvirt/libvirt.cmx diff --git a/examples/Makefile.in b/examples/Makefile.in index 2eb220a..041e382 100644 --- a/examples/Makefile.in +++ b/examples/Makefile.in @@ -27,7 +27,7 @@ OCAMLOPTLIBS := $(OCAMLCLIBS) export LIBRARY_PATH=../libvirt export LD_LIBRARY_PATH=../libvirt -BYTE_TARGETS := list_domains node_info get_cpu_stats +BYTE_TARGETS := list_domains node_info get_cpu_stats domain_events OPT_TARGETS := $(BYTE_TARGETS:%=%.opt) all: $(BYTE_TARGETS) @@ -64,6 +64,17 @@ get_cpu_stats.opt: get_cpu_stats.cmx $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ ../libvirt/mllibvirt.cmxa -o $@ $< +domain_events: domain_events.cmo + $(OCAMLFIND) ocamlc \ + $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + ../libvirt/mllibvirt.cma -o $@ $< + +domain_events.opt: domain_events.cmx + $(OCAMLFIND) ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + ../libvirt/mllibvirt.cmxa -o $@ $< + + install-opt install-byte: include ../Make.rules diff --git a/examples/domain_events.ml b/examples/domain_events.ml new file mode 100644 index 0000000..03cecd9 --- /dev/null +++ b/examples/domain_events.ml @@ -0,0 +1,145 @@ +(* Simple demo program showing how to receive domain events. + Usage: domain_events [URI] + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + (C) Copyright 2013 Citrix Inc + http://libvirt.org/ + *) + +open Printf + +module C = Libvirt.Connect +module D = Libvirt.Domain +module E = Libvirt.Event +module N = Libvirt.Network + +let string_of_state = function + | D.InfoNoState -> "no state" + | D.InfoRunning -> "running" + | D.InfoBlocked -> "blocked" + | D.InfoPaused -> "paused" + | D.InfoShutdown -> "shutdown" + | D.InfoShutoff -> "shutoff" + | D.InfoCrashed -> "crashed" + +let printd dom fmt = + let prefix dom = + let id = D.get_id dom in + try + let name = D.get_name dom in + let info = D.get_info dom in + let state = string_of_state info.D.state in + sprintf "%8d %-20s %s " id name state + with _ -> + sprintf "%8d " id in + let write x = + output_string stdout (prefix dom); + output_string stdout x; + output_string stdout "\n"; + flush stdout in + Printf.ksprintf write fmt + +let string_option = function + | None -> "None" + | Some x -> "Some " ^ x + +let string_of_graphics_address (family, node, service) = + Printf.sprintf "{ family=%d; node=%s; service=%s }" family (string_option node) (string_option service) + +let string_of_graphics_subject_identity (ty, name) = + Printf.sprintf "{ type=%s; name=%s }" (string_option ty) (string_option name) + +let string_of_graphics_subject xs = String.concat "; " (List.map string_of_graphics_subject_identity (Array.to_list xs)) + +let map_option f = function + | None -> None + | Some x -> Some (f x) + +let () = + try + E.register_default_impl (); + let name = + if Array.length Sys.argv >= 2 then + Some (Sys.argv.(1)) + else + None in + let conn = C.connect_readonly ?name () in + + let spinner = [| '|'; '/'; '-'; '\\' |] in + + let timeouts = ref 0 in + (* Check add/remove works *) + let id = E.add_timeout conn 250 (fun () -> Printf.printf "This callback is immediately deregistered\n%!") in + E.remove_timeout conn id; + + let (_: E.timer_id) = E.add_timeout conn 250 (* ms *) + (fun () -> + incr timeouts; + Printf.printf "\r%c %d timeout callbacks%!" (spinner.(!timeouts mod (Array.length spinner))) !timeouts; + (* Check for GC errors: *) + Gc.compact () + ) in + + (* Check add/remove works *) + let id = E.register_any conn (E.Lifecycle (fun dom e -> + printd dom "Removed Lifecycle callback %s" (E.Lifecycle.to_string e) + )) in + E.deregister_any conn id; + + let (_: E.callback_id) = E.register_any conn (E.Lifecycle (fun dom e -> + printd dom "Lifecycle %s" (E.Lifecycle.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.Reboot (fun dom e -> + printd dom "Reboot %s" (E.Reboot.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.RtcChange (fun dom e -> + printd dom "RtcChange %s" (E.Rtc_change.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.Watchdog (fun dom e -> + printd dom "Watchdog %s" (E.Watchdog.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.IOError (fun dom e -> + printd dom "IOError %s" (E.Io_error.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.IOErrorReason (fun dom e -> + printd dom "IOErrorReason %s" (E.Io_error.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.Graphics (fun dom e -> + printd dom "Graphics %s" (E.Graphics.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.ControlError (fun dom e -> + printd dom "ControlError %s" (E.Control_error.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.BlockJob (fun dom e -> + printd dom "BlockJob %s" (E.Block_job.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.DiskChange (fun dom e -> + printd dom "DiskChange %s" (E.Disk_change.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.TrayChange (fun dom e -> + printd dom "TrayChange %s" (E.Tray_change.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.PMWakeUp (fun dom e -> + printd dom "PMWakeup %s" (E.PM_wakeup.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.PMSuspend (fun dom e -> + printd dom "PMSuspend %s" (E.PM_suspend.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.BalloonChange (fun dom e -> + printd dom "BalloonChange %s" (E.Balloon_change.to_string e) + )) in + let (_: E.callback_id) = E.register_any conn (E.PMSuspendDisk (fun dom x -> + printd dom "PMSuspendDisk %s" (E.PM_suspend_disk.to_string x) + )) in + C.set_keep_alive conn 5 3; + while true do + E.run_default_impl () + done + with + Libvirt.Virterror err -> + eprintf "error: %s\n" (Libvirt.Virterror.to_string err) + +let () = + (* Run the garbage collector which is a good way to check for + * memory corruption errors and reference counting issues in libvirt. + *) + Gc.compact () -- 1.8.1.2 -- libvir-list mailing list libvir-list@xxxxxxxxxx https://www.redhat.com/mailman/listinfo/libvir-list