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'.

diff --git a/.depend b/.depend
index af5fe13..f90ce09 100644 (file)
--- 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
 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
 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
 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 (file)
--- 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.
 
         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
         module. *)
 
   method after : 'a

diff --git a/main.ml b/main.ml
index 93e2a3a..c908bbc 100644 (file)
--- a/main.ml
+++ b/main.ml
@@ -33,13 +33,51 @@ let () =
     debug "libvirt %s" (libvirt_version_string ());
   );
 
     debug "libvirt %s" (libvirt_version_string ());
   );
 

+  (* Create the main window. *)

   let w = new Window.window in
   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;
 
   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;
 
   (* 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 (file)
--- a/window.ml
+++ b/window.ml
@@ -23,7 +23,13 @@ open Slave_types
 
 module G = Guestfs
 
 
 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
   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
   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
   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. *)
 
   (* Combo box for displaying virtual machine names. *)

-  hbox#pack (mklabel "Guest: ");

   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
 
   (* Refresh button.
   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
 
   (* Refresh button.


@@ -72,88 +72,56 @@ and make_toolbar ~packing () =
     b in
 
   (* Throbber. *)
     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
   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. *)
   (* 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
 
   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
 
   (* 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)
 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 ();
 
   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
     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
     ignore (connect_xen_item#connect#activate

-              ~callback:(fun () -> self#connect_to (Some "xen:///")));
+              ~callback:connect_xen_signal#call);

     ignore (connect_none_item#connect#activate
     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.
 
     (* 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)
 
     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)
 
     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 =
 
   (* 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)
 
     Slave.discard_command_queue ();
     Slave.open_domain name (self#when_opened_domain name)
 


@@ -223,7 +190,7 @@ object (self)
     match images with
     | [] -> ()
     | images ->
     match images with
     | [] -> ()
     | images ->

-        self#clear_view ();
+        tree#clear ();

         Slave.discard_command_queue ();
         Slave.open_images images (self#when_opened_disk_images images)
 
         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;
 
         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 () =
 
   (* Public callbacks. *)
   method throbber_busy () =

diff --git a/window.mli b/window.mli
index 0b2acb5..ba44e5e 100644 (file)
--- a/window.mli
+++ b/window.mli
@@ -20,7 +20,16 @@
     dialogs and so on. *)
 
 class window :
     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
   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 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
   method run_cli_request : Cmdline.cli_request -> unit
     (** This function performs the {!Cmdline.cli_request} operation.
         The actual operation happens asynchronously after this function