From 2ed92137182d4d479dddddeccaf6ad8dae967895 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 28 Jul 2011 23:32:12 +0100 Subject: [PATCH] Use signals to loosely couple modules. Rearchitect the use of signals so that menu entries emit signals. Everything is "plugged together" in a single place in 'main.ml'. --- .depend | 10 ++--- filetree.mli | 2 +- main.ml | 38 ++++++++++++++++ window.ml | 145 +++++++++++++++++++++++------------------------------------ window.mli | 17 ++++++- 5 files changed, 116 insertions(+), 96 deletions(-) diff --git a/.depend b/.depend index af5fe13..f90ce09 100644 --- a/.depend +++ b/.depend @@ -13,8 +13,8 @@ filetree.cmx: utils.cmx slave_types.cmx slave.cmx filetree_markup.cmx deviceSet. filetree_markup.cmi: slave_types.cmi filetree_markup.cmo: utils.cmi slave_types.cmi filetree_markup.cmi filetree_markup.cmx: utils.cmx slave_types.cmx filetree_markup.cmi -main.cmo: window.cmi utils.cmi slave.cmi config.cmi cmdline.cmi -main.cmx: window.cmx utils.cmx slave.cmx config.cmx cmdline.cmx +main.cmo: window.cmi utils.cmi slave.cmi op_view_file.cmi op_inspection_dialog.cmi op_file_information.cmi op_download_file.cmi op_download_dir_tarball.cmi op_download_dir_find0.cmi op_download_as_reg.cmi op_disk_usage.cmi op_copy_regvalue.cmi op_checksum_file.cmi config.cmi cmdline.cmi +main.cmx: window.cmx utils.cmx slave.cmx op_view_file.cmx op_inspection_dialog.cmx op_file_information.cmx op_download_file.cmx op_download_dir_tarball.cmx op_download_dir_find0.cmx op_download_as_reg.cmx op_disk_usage.cmx op_copy_regvalue.cmx op_checksum_file.cmx config.cmx cmdline.cmx op_checksum_file.cmi: filetree.cmi op_checksum_file.cmo: utils.cmi slave.cmi op_checksum_file.cmi op_checksum_file.cmx: utils.cmx slave.cmx op_checksum_file.cmi @@ -59,6 +59,6 @@ throbber.cmx: utils.cmi: utils.cmo: config.cmi utils.cmi utils.cmx: config.cmx utils.cmi -window.cmi: cmdline.cmi -window.cmo: utils.cmi throbber.cmo slave_types.cmi slave.cmi op_view_file.cmi op_inspection_dialog.cmi op_file_information.cmi op_download_file.cmi op_download_dir_tarball.cmi op_download_dir_find0.cmi op_download_as_reg.cmi op_disk_usage.cmi op_copy_regvalue.cmi op_checksum_file.cmi filetree.cmi cmdline.cmi window.cmi -window.cmx: utils.cmx throbber.cmx slave_types.cmx slave.cmx op_view_file.cmx op_inspection_dialog.cmx op_file_information.cmx op_download_file.cmx op_download_dir_tarball.cmx op_download_dir_find0.cmx op_download_as_reg.cmx op_disk_usage.cmx op_copy_regvalue.cmx op_checksum_file.cmx filetree.cmx cmdline.cmx window.cmi +window.cmi: filetree.cmi cmdline.cmi +window.cmo: utils.cmi throbber.cmo slave_types.cmi slave.cmi filetree.cmi cmdline.cmi window.cmi +window.cmx: utils.cmx throbber.cmx slave_types.cmx slave.cmx filetree.cmx cmdline.cmx window.cmi diff --git a/filetree.mli b/filetree.mli index 697bb5e..b6af8ce 100644 --- a/filetree.mli +++ b/filetree.mli @@ -104,7 +104,7 @@ object ('a) the code split into small modules, with the filetree widget just emitting signals when some action needs to take place. - All the components are wired together in the {!Window} + All the components are wired together in the {!Main} module. *) method after : 'a diff --git a/main.ml b/main.ml index 93e2a3a..c908bbc 100644 --- a/main.ml +++ b/main.ml @@ -33,13 +33,51 @@ let () = debug "libvirt %s" (libvirt_version_string ()); ); + (* Create the main window. *) let w = new Window.window in + + (* Wire up hooks that carry messages from the slave thread + * to the main thread. + *) Slave.set_failure_hook w#failure; Slave.set_busy_hook w#throbber_busy; Slave.set_idle_hook w#throbber_idle; Slave.set_status_hook w#set_statusbar; Slave.set_progress_hook w#progress; + (* Wire up the loosely-coupled external components of the filetree. + * See the note about signals in {!Filetree.tree} documentation. + *) + let tree = w#tree in + ignore (tree#op_checksum_file + ~callback:(Op_checksum_file.checksum_file tree)); + ignore (tree#op_copy_regvalue + ~callback:(Op_copy_regvalue.copy_regvalue tree)); + ignore (tree#op_disk_usage + ~callback:(Op_disk_usage.disk_usage tree)); + ignore (tree#op_download_as_reg + ~callback:(Op_download_as_reg.download_as_reg tree)); + ignore (tree#op_download_dir_find0 + ~callback:(Op_download_dir_find0.download_dir_find0 tree)); + ignore (tree#op_download_dir_tarball + ~callback:(Op_download_dir_tarball.download_dir_tarball tree)); + ignore (tree#op_download_file + ~callback:(Op_download_file.download_file tree)); + ignore (tree#op_file_information + ~callback:(Op_file_information.file_information tree)); + ignore (tree#op_inspection_dialog + ~callback:(Op_inspection_dialog.inspection_dialog tree)); + ignore (tree#op_view_file + ~callback:(Op_view_file.view_file tree)); + + (* Connect menu entry signals to the functions that implement them. *) + ignore (w#connect_kvm_signal + ~callback:(w#connect_to (Some "qemu:///system"))); + ignore (w#connect_xen_signal + ~callback:(w#connect_to (Some "xen:///"))); + ignore (w#connect_none_signal + ~callback:(w#connect_to None)); + (* What did the user request on the command line? *) w#run_cli_request cli_request; diff --git a/window.ml b/window.ml index aa33b79..a43bf9c 100644 --- a/window.ml +++ b/window.ml @@ -23,7 +23,13 @@ open Slave_types module G = Guestfs -let make_menubar window (vbox : GPack.box) ~packing () = +class window = + (* Window. *) + let title = "Guest Filesystem Browser" in + let window = GWindow.window ~width:700 ~height:700 ~title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Menus. *) let menubar = GMenu.menu_bar ~packing:vbox#pack () in let factory = new GMenu.factory menubar in let accel_group = factory#accel_group in @@ -34,32 +40,26 @@ let make_menubar window (vbox : GPack.box) ~packing () = let connect_xen_item = factory#add_item "Connect to local _Xen hypervisor" in let connect_none_item = factory#add_item "_Connect to default hypervisor" in let connect_uri_item = factory#add_item "Connect to a _libvirt URI ..." in - ignore (factory#add_separator ()); - let open_image_item = - factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in - ignore (factory#add_separator ()); + let () = ignore (factory#add_separator ()) in + let _ = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in + let () = ignore (factory#add_separator ()) in let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in (* Quit. *) let quit _ = GMain.quit (); false in - ignore (window#connect#destroy ~callback:GMain.quit); - ignore (window#event#connect#delete ~callback:quit); - ignore (quit_item#connect#activate - ~callback:(fun () -> ignore (quit ()); ())); + let () = + ignore (window#connect#destroy ~callback:GMain.quit); + ignore (window#event#connect#delete ~callback:quit); + ignore (quit_item#connect#activate + ~callback:(fun () -> ignore (quit ()); ())); - window#add_accel_group accel_group; + window#add_accel_group accel_group in - connect_kvm_item, connect_xen_item, connect_none_item, - connect_uri_item, open_image_item - -(* Top toolbar. In fact, not a toolbar because you don't seem to be - * able to put a combo box into a toolbar, so it's just an hbox for now. - *) -and make_toolbar ~packing () = - let hbox = GPack.hbox ~border_width:4 ~packing () in + (* Top toolbar. *) + let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in + let () = hbox#pack (mklabel "Guest: ") in (* Combo box for displaying virtual machine names. *) - hbox#pack (mklabel "Guest: "); let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in (* Refresh button. @@ -72,88 +72,56 @@ and make_toolbar ~packing () = b in (* Throbber. *) - let static = Throbber.static () in - let animation = Throbber.animation () in + let throbber_static = Throbber.static () in + let throbber_animation = Throbber.animation () in let throbber = (* Workaround for http://caml.inria.fr/mantis/view.php?id=4732 *) let from = Obj.magic 3448763 (* `END *) in - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from) () in - - vmcombo, refresh_button, throbber, static, animation + GMisc.image ~pixbuf:throbber_static ~packing:(hbox#pack ~from) () in -and make_filetree ~packing () = + (* Main part of display is the file tree. *) (* Create the filetree inside a scrolled window. *) - let sw = - GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in + let sw = GBin.scrolled_window + ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS + ~packing:(vbox#pack ~expand:true ~fill:true) () in let tree = new Filetree.tree ~packing:sw#add () in - (* Wire up the loosely-coupled external components of the filetree. - * See the note about signals in {!Filetree.tree} documentation. - *) - ignore (tree#op_checksum_file - ~callback:(Op_checksum_file.checksum_file tree)); - ignore (tree#op_copy_regvalue - ~callback:(Op_copy_regvalue.copy_regvalue tree)); - ignore (tree#op_disk_usage - ~callback:(Op_disk_usage.disk_usage tree)); - ignore (tree#op_download_as_reg - ~callback:(Op_download_as_reg.download_as_reg tree)); - ignore (tree#op_download_dir_find0 - ~callback:(Op_download_dir_find0.download_dir_find0 tree)); - ignore (tree#op_download_dir_tarball - ~callback:(Op_download_dir_tarball.download_dir_tarball tree)); - ignore (tree#op_download_file - ~callback:(Op_download_file.download_file tree)); - ignore (tree#op_file_information - ~callback:(Op_file_information.file_information tree)); - ignore (tree#op_inspection_dialog - ~callback:(Op_inspection_dialog.inspection_dialog tree)); - ignore (tree#op_view_file - ~callback:(Op_view_file.view_file tree)); - - tree - -class window = - (* I prototyped the basic window layout using Glade, but have - * implemented it by hand to give us more flexibility. - *) - let title = "Guest Filesystem Browser" in - let window = GWindow.window ~width:700 ~height:700 ~title () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Menus. *) - let connect_kvm_item, connect_xen_item, connect_none_item, _, _ = - make_menubar window vbox ~packing:vbox#pack () in - - (* Top toolbar. *) - let vmcombo, refresh_button, throbber, throbber_static, throbber_animation = - make_toolbar ~packing:vbox#pack () in - - (* Main part of display is the file tree. *) - let view = make_filetree ~packing:(vbox#pack ~expand:true ~fill:true) () in - (* Status bar and progress bar. *) let hbox = GPack.hbox ~spacing:4 ~packing:vbox#pack () in let progress_bar = GRange.progress_bar ~packing:hbox#pack () in let statusbar = GMisc.statusbar ~packing:(hbox#pack ~expand:true) () in let statusbar_context = statusbar#new_context ~name:"Standard" in + (* Signals. *) + let connect_kvm_signal = new GUtil.signal () in + let connect_xen_signal = new GUtil.signal () in + let connect_none_signal = new GUtil.signal () in + let connect_uri_signal = new GUtil.signal () in + object (self) + inherit GUtil.ml_signals [connect_kvm_signal#disconnect; + connect_xen_signal#disconnect; + connect_none_signal#disconnect; + connect_uri_signal#disconnect] + + method connect_kvm_signal = connect_kvm_signal#connect ~after + method connect_xen_signal = connect_xen_signal#connect ~after + method connect_none_signal = connect_none_signal#connect ~after + method connect_uri_signal = connect_uri_signal#connect ~after + initializer ignore (statusbar_context#push title); window#show (); - (* Connect up the callback for menu entries etc. These require the - * window_state struct in callbacks. - *) - - (* Connect to different hypervisors. *) + (* Menu entries emit signals. *) ignore (connect_kvm_item#connect#activate - ~callback:(fun () -> self#connect_to (Some "qemu:///system"))); + ~callback:connect_kvm_signal#call); ignore (connect_xen_item#connect#activate - ~callback:(fun () -> self#connect_to (Some "xen:///"))); + ~callback:connect_xen_signal#call); ignore (connect_none_item#connect#activate - ~callback:(fun () -> self#connect_to None)); + ~callback:connect_none_signal#call); + ignore (connect_uri_item#connect#activate + ~callback:connect_uri_signal#call); (* VM combo box when changed by the user. * The refresh button acts like changing the VM combo too. @@ -183,13 +151,12 @@ object (self) statusbar_context#pop (); ignore (statusbar_context#push msg) - (* Clear the filetree. *) - method private clear_view () = - view#clear () + (* Return the filetree. *) + method tree = tree - (* Callback from Connect -> ... menu items. *) - method private connect_to uri = - self#clear_view (); + (* Connect to the given URI. *) + method connect_to uri () = + tree#clear (); Slave.discard_command_queue (); Slave.connect uri (self#when_connected uri) @@ -209,7 +176,7 @@ object (self) (* When a new domain is selected by the user, eg through vmcombo. *) method private open_domain name = - self#clear_view (); + tree#clear (); Slave.discard_command_queue (); Slave.open_domain name (self#when_opened_domain name) @@ -223,7 +190,7 @@ object (self) match images with | [] -> () | images -> - self#clear_view (); + tree#clear (); Slave.discard_command_queue (); Slave.open_images images (self#when_opened_disk_images images) @@ -246,7 +213,7 @@ object (self) debug "root device %s contains %s %s %d.%d" root typ distro major minor; ) data.insp_oses; - view#add_os name data + tree#add_os name data (* Public callbacks. *) method throbber_busy () = diff --git a/window.mli b/window.mli index 0b2acb5..ba44e5e 100644 --- a/window.mli +++ b/window.mli @@ -20,7 +20,16 @@ dialogs and so on. *) class window : -object +object ('a) + method after : 'a + method disconnect : GtkSignal.id -> unit + + (** Signals that can be emitted by window. *) + method connect_kvm_signal : callback:(unit -> unit) -> GtkSignal.id + method connect_xen_signal : callback:(unit -> unit) -> GtkSignal.id + method connect_none_signal : callback:(unit -> unit) -> GtkSignal.id + method connect_uri_signal : callback:(unit -> unit) -> GtkSignal.id + method failure : exn -> unit (** This is the global error handling function. It is invoked in the main thread for failures in the slave thread (see @@ -40,6 +49,12 @@ object method progress : int64 * int64 -> unit (** This called whenever the progress bar should move. *) + method tree : Filetree.tree + (** Return the filetree contained in the window. *) + + method connect_to : string option -> unit -> unit + (** Connect to the given libvirt URI. *) + method run_cli_request : Cmdline.cli_request -> unit (** This function performs the {!Cmdline.cli_request} operation. The actual operation happens asynchronously after this function -- 1.8.3.1