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"
26 let id = D.get_id dom in
28 let name = D.get_name dom in
29 let info = D.get_info dom in
30 let state = string_of_state info.D.state in
31 sprintf "%8d %-20s %s " id name state
35 output_string stdout (prefix dom);
36 output_string stdout x;
37 output_string stdout "\n";
39 Printf.ksprintf write fmt
41 let string_option = function
43 | Some x -> "Some " ^ x
45 let string_of_graphics_address (family, node, service) =
46 Printf.sprintf "{ family=%d; node=%s; service=%s }" family (string_option node) (string_option service)
48 let string_of_graphics_subject_identity (ty, name) =
49 Printf.sprintf "{ type=%s; name=%s }" (string_option ty) (string_option name)
51 let string_of_graphics_subject xs = String.concat "; " (List.map string_of_graphics_subject_identity (Array.to_list xs))
53 let map_option f = function
55 | Some x -> Some (f x)
59 E.register_default_impl ();
61 if Array.length Sys.argv >= 2 then
65 let conn = C.connect_readonly ?name () in
67 let spinner = [| '|'; '/'; '-'; '\\' |] in
69 let timeouts = ref 0 in
70 (* Check add/remove works *)
71 let id = E.add_timeout conn 250 (fun () -> Printf.printf "This callback is immediately deregistered\n%!") in
72 E.remove_timeout conn id;
74 let (_: E.timer_id) = E.add_timeout conn 250 (* ms *)
77 Printf.printf "\r%c %d timeout callbacks%!" (spinner.(!timeouts mod (Array.length spinner))) !timeouts;
78 (* Check for GC errors: *)
82 (* Check add/remove works *)
83 let id = E.register_any conn (E.Lifecycle (fun dom e ->
84 printd dom "Removed Lifecycle callback %s" (E.Lifecycle.to_string e)
86 E.deregister_any conn id;
88 let (_: E.callback_id) = E.register_any conn (E.Lifecycle (fun dom e ->
89 printd dom "Lifecycle %s" (E.Lifecycle.to_string e)
91 let (_: E.callback_id) = E.register_any conn (E.Reboot (fun dom e ->
92 printd dom "Reboot %s" (E.Reboot.to_string e)
94 let (_: E.callback_id) = E.register_any conn (E.RtcChange (fun dom e ->
95 printd dom "RtcChange %s" (E.Rtc_change.to_string e)
97 let (_: E.callback_id) = E.register_any conn (E.Watchdog (fun dom e ->
98 printd dom "Watchdog %s" (E.Watchdog.to_string e)
100 let (_: E.callback_id) = E.register_any conn (E.IOError (fun dom e ->
101 printd dom "IOError %s" (E.Io_error.to_string e)
103 let (_: E.callback_id) = E.register_any conn (E.IOErrorReason (fun dom e ->
104 printd dom "IOErrorReason %s" (E.Io_error.to_string e)
106 let (_: E.callback_id) = E.register_any conn (E.Graphics (fun dom e ->
107 printd dom "Graphics %s" (E.Graphics.to_string e)
109 let (_: E.callback_id) = E.register_any conn (E.ControlError (fun dom e ->
110 printd dom "ControlError %s" (E.Control_error.to_string e)
112 let (_: E.callback_id) = E.register_any conn (E.BlockJob (fun dom e ->
113 printd dom "BlockJob %s" (E.Block_job.to_string e)
115 let (_: E.callback_id) = E.register_any conn (E.DiskChange (fun dom e ->
116 printd dom "DiskChange %s" (E.Disk_change.to_string e)
118 let (_: E.callback_id) = E.register_any conn (E.TrayChange (fun dom e ->
119 printd dom "TrayChange %s" (E.Tray_change.to_string e)
121 let (_: E.callback_id) = E.register_any conn (E.PMWakeUp (fun dom e ->
122 printd dom "PMWakeup %s" (E.PM_wakeup.to_string e)
124 let (_: E.callback_id) = E.register_any conn (E.PMSuspend (fun dom e ->
125 printd dom "PMSuspend %s" (E.PM_suspend.to_string e)
127 let (_: E.callback_id) = E.register_any conn (E.BalloonChange (fun dom e ->
128 printd dom "BalloonChange %s" (E.Balloon_change.to_string e)
130 let (_: E.callback_id) = E.register_any conn (E.PMSuspendDisk (fun dom x ->
131 printd dom "PMSuspendDisk %s" (E.PM_suspend_disk.to_string x)
133 C.set_keep_alive conn 5 3;
135 E.run_default_impl ()
138 Libvirt.Virterror err ->
139 eprintf "error: %s\n" (Libvirt.Virterror.to_string err)
142 (* Run the garbage collector which is a good way to check for
143 * memory corruption errors and reference counting issues in libvirt.