1 (* Simple demo program showing how to receive domain events.
2 Usage: domain_events [URI]
3 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
4 (C) Copyright 2013 Citrix Inc
10 module C = Libvirt.Connect
11 module D = Libvirt.Domain
12 module E = Libvirt.Event
13 module N = Libvirt.Network
15 let string_of_state = function
16 | D.InfoNoState -> "no state"
17 | D.InfoRunning -> "running"
18 | D.InfoBlocked -> "blocked"
19 | D.InfoPaused -> "paused"
20 | D.InfoShutdown -> "shutdown"
21 | D.InfoShutoff -> "shutoff"
22 | D.InfoCrashed -> "crashed"
23 | D.InfoPMSuspended -> "pm suspended"
27 let id = D.get_id dom in
29 let name = D.get_name dom in
30 let info = D.get_info dom in
31 let state = string_of_state info.D.state in
32 sprintf "%8d %-20s %s " id name state
36 output_string stdout (prefix dom);
37 output_string stdout x;
38 output_string stdout "\n";
40 Printf.ksprintf write fmt
42 let string_option = function
44 | Some x -> "Some " ^ x
46 let string_of_graphics_address (family, node, service) =
47 Printf.sprintf "{ family=%d; node=%s; service=%s }" family (string_option node) (string_option service)
49 let string_of_graphics_subject_identity (ty, name) =
50 Printf.sprintf "{ type=%s; name=%s }" (string_option ty) (string_option name)
52 let string_of_graphics_subject xs = String.concat "; " (List.map string_of_graphics_subject_identity (Array.to_list xs))
54 let map_option f = function
56 | Some x -> Some (f x)
60 E.register_default_impl ();
62 if Array.length Sys.argv >= 2 then
66 let conn = C.connect_auth_readonly ?name (C.get_auth_default ()) in
68 let spinner = [| '|'; '/'; '-'; '\\' |] in
70 let timeouts = ref 0 in
71 (* Check add/remove works *)
72 let id = E.add_timeout conn 250 (fun () -> Printf.printf "This callback is immediately deregistered\n%!") in
73 E.remove_timeout conn id;
75 let (_: E.timer_id) = E.add_timeout conn 250 (* ms *)
78 Printf.printf "\r%c %d timeout callbacks%!" (spinner.(!timeouts mod (Array.length spinner))) !timeouts;
79 (* Check for GC errors: *)
83 (* Check add/remove works *)
84 let id = E.register_any conn (E.Lifecycle (fun dom e ->
85 printd dom "Removed Lifecycle callback %s" (E.Lifecycle.to_string e)
87 E.deregister_any conn id;
89 let (_: E.callback_id) = E.register_any conn (E.Lifecycle (fun dom e ->
90 printd dom "Lifecycle %s" (E.Lifecycle.to_string e)
92 let (_: E.callback_id) = E.register_any conn (E.Reboot (fun dom e ->
93 printd dom "Reboot %s" (E.Reboot.to_string e)
95 let (_: E.callback_id) = E.register_any conn (E.RtcChange (fun dom e ->
96 printd dom "RtcChange %s" (E.Rtc_change.to_string e)
98 let (_: E.callback_id) = E.register_any conn (E.Watchdog (fun dom e ->
99 printd dom "Watchdog %s" (E.Watchdog.to_string e)
101 let (_: E.callback_id) = E.register_any conn (E.IOError (fun dom e ->
102 printd dom "IOError %s" (E.Io_error.to_string e)
104 let (_: E.callback_id) = E.register_any conn (E.IOErrorReason (fun dom e ->
105 printd dom "IOErrorReason %s" (E.Io_error.to_string e)
107 let (_: E.callback_id) = E.register_any conn (E.Graphics (fun dom e ->
108 printd dom "Graphics %s" (E.Graphics.to_string e)
110 let (_: E.callback_id) = E.register_any conn (E.ControlError (fun dom e ->
111 printd dom "ControlError %s" (E.Control_error.to_string e)
113 let (_: E.callback_id) = E.register_any conn (E.BlockJob (fun dom e ->
114 printd dom "BlockJob %s" (E.Block_job.to_string e)
116 let (_: E.callback_id) = E.register_any conn (E.DiskChange (fun dom e ->
117 printd dom "DiskChange %s" (E.Disk_change.to_string e)
119 let (_: E.callback_id) = E.register_any conn (E.TrayChange (fun dom e ->
120 printd dom "TrayChange %s" (E.Tray_change.to_string e)
122 let (_: E.callback_id) = E.register_any conn (E.PMWakeUp (fun dom e ->
123 printd dom "PMWakeup %s" (E.PM_wakeup.to_string e)
125 let (_: E.callback_id) = E.register_any conn (E.PMSuspend (fun dom e ->
126 printd dom "PMSuspend %s" (E.PM_suspend.to_string e)
128 let (_: E.callback_id) = E.register_any conn (E.BalloonChange (fun dom e ->
129 printd dom "BalloonChange %s" (E.Balloon_change.to_string e)
131 let (_: E.callback_id) = E.register_any conn (E.PMSuspendDisk (fun dom x ->
132 printd dom "PMSuspendDisk %s" (E.PM_suspend_disk.to_string x)
134 C.set_keep_alive conn 5 3;
136 E.run_default_impl ()
139 Libvirt.Virterror err ->
140 eprintf "error: %s\n" (Libvirt.Virterror.to_string err)
143 (* Run the garbage collector which is a good way to check for
144 * memory corruption errors and reference counting issues in libvirt.